从多个工作簿复制特定数据

Question

我是 VBA 的新手，我一直在尝试创建一个程序来将特定范围从工作表 2 中有数据的多个工作簿复制到主工作簿工作表 2。

复制条件：列范围将为A20到AS20，而行范围将取决于R列中具有数据的最后一个单元格。

粘贴条件：从A20行开始，应连续粘贴所有复制的单元格，中间应粘贴一个空白行

复制粘贴条件：范围 D5 ：D18 从源书到主图纸，以重叠的方式，因为范围在所有源书中都是相同的。

我来到了下面的阶段，但没有进一步的想法。做了一些更正，但效果不佳。

进度：

Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False

Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge

For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then

Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With
insertRow = masterBook.Sheets("Service Order Template").Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
Application.ScreenUpdating = True
End Sub

Answer 1

检查一下。如果问题，请参阅代码中的注释 - 将注释放在答案中。希望你能找到新的东西。您必须将此代码放入主工作簿中的模块。

Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
' add variables for blank check
Dim checkRange As Range, r As Range
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False

Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge

For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
' copy additional needed range D5 : D18 from source to range D5 on master
Range(.Cells(5, 4), .Cells(18, 4)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(5, 4)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With     
masterBook.Sheets("Service Order Template").insertRow = .Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
With masterBook.Sheets("Service Order Template")
' if you don't need to highlight the whole row - remove the ".EntireRow" part →---→---→----↓
Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
End With
Application.ScreenUpdating = True
End Sub