如何将工作簿中其他选项卡的行复制并粘贴回主工作簿

下午，

我试图从多个工作簿中的多个（3）选项卡复制多个ROWS。

到目前为止，我已经编写了一些代码，它们将抓取多个工作簿的第一个选项卡，并将每一行复制到一个“主”工作簿中。

我很好。

但是，我缺乏能够复制工作簿中的其他选项卡中的行！

这实在是在烦扰我，希望有人能帮助我。 我继续前进，并在下面放下我的代码，以便更好地了解我的位置。

好消息：所有工作簿包含3个选项卡。 它们以相同的方式格式化。 我只需要弄清楚如何将这些工作簿中的其他选项卡的行复制回主工作簿。

提前致谢。

'Description: Combines all files in a folder to a master file. Sub MergeFiles() Dim path As String, ThisWB As String, lngFilecounter As Long Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet Dim Filename As String, Wkb As Workbook Dim CopyRng As Range, Dest As Range Dim RowofCopySheet As Integer RowofCopySheet = 2 ' Row to start on in the sheets you are copying from ThisWB = ActiveWorkbook.Name path = Application.FileDialog(msoFileDialogFolderPicker).Show MsgBox "Get Ready!" Application.ScreenUpdating = False 'Deletes all rows Sheets("RAW").Select Rows("2:2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Delete Shift:=xlUp Sheets("BK").Select Rows("2:2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Delete Shift:=xlUp Sheets("RAW").Select 'End delete all rows 'Pick folder With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False path = .SelectedItems(1) End With 'End pick folder Application.EnableEvents = False Set shtDest = ActiveWorkbook.Sheets(1) Filename = Dir(path & "\*.xls", vbNormal) If Len(Filename) = 0 Then Exit Sub Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename) Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False End If Filename = Dir() Loop 'Remove Duplicates Range("A1").Select Columns("A:A").Select ActiveSheet.Range("$A$1:$T$40002").RemoveDuplicates Columns:=1, Header:=xlYes Range("F20").Select Application.EnableEvents = True Application.ScreenUpdating = True 'End Remove Duplicates MsgBox "Voila!" End Sub 

我想我可能已经解决了这个问题！

  'Description: Combines all files in a folder to a master file. Sub MergeFiles() Dim path As String, ThisWB As String, lngFilecounter As Long Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet Dim Filename As String, Wkb As Workbook Dim CopyRng As Range, Dest As Range Dim RowofCopySheet As Integer RowofCopySheet = 2 ' Row to start on in the sheets you are copying from ThisWB = ActiveWorkbook.Name path = Application.FileDialog(msoFileDialogFolderPicker).Show MsgBox "Get Ready!" Application.ScreenUpdating = False 'Deletes all rows Sheets("RAW").Select Rows("2:2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Delete Shift:=xlUp Sheets("BK").Select Rows("2:2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Delete Shift:=xlUp Sheets("RAW").Select 'End delete all rows 'Pick folder With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False path = .SelectedItems(1) End With 'End pick folder Application.EnableEvents = False 'Sheet 1 Set shtDest = ActiveWorkbook.Sheets(1) Filename = Dir(path & "\*.xls", vbNormal) If Len(Filename) = 0 Then Exit Sub Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename) Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False End If Filename = Dir() Loop 'Sheet 2 Set shtDest = ActiveWorkbook.Sheets(1) Filename = Dir(path & "\*.xls", vbNormal) If Len(Filename) = 0 Then Exit Sub Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename) Application.GoTo Wkb.Sheets(2).Range("A1") Set CopyRng = Wkb.Sheets(2).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False End If Filename = Dir() Loop 'Sheet 3 Set shtDest = ActiveWorkbook.Sheets(1) Filename = Dir(path & "\*.xls", vbNormal) If Len(Filename) = 0 Then Exit Sub Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename) Application.GoTo Wkb.Sheets(3).Range("A1") Set CopyRng = Wkb.Sheets(3).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False End If Filename = Dir() Loop 'Remove Duplicates Range("A1").Select Columns("A:A").Select ActiveSheet.Range("$A$1:$T$40002").RemoveDuplicates Columns:=1, Header:=xlYes Range("F20").Select Application.EnableEvents = True Application.ScreenUpdating = True 'End Remove Duplicates MsgBox "Voila!" End Sub 

Answer 1

  Option Explicit PUblic Function FileBrowse(Optional FilenameToSearchFor As String, Optional Caption As String = "") On Error GoTo error_Handler Dim lngCount As Long Dim xFilename As String Dim iRow As Long Dim xFileNPath As String Dim tmp As Variant ' Open the file dialog With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = True If Caption <> "" Then .Title = Caption End If .InitialFileName = FilenameToSearchFor .Show ' Display paths of each file selected For lngCount = 1 To .SelectedItems.Count xFilename = .SelectedItems(lngCount) FileBrowse = xFilename ' If IsWorkbookOpen(xFilename) Then ' Workbooks(xFilename).Close SaveChanges:=False ' 'Exit Sub ' End If ' Workbooks.Open xFilename Next lngCount End With Exit Function error_Handler: Debug.Print "FileBrowse", Err, Err.Description Stop End Function 

Answer 2

把你的文件夹/文件select器放在一个独立的函数中，你可以调用它来返回选定的文件夹。

如果你想打开一个文件夹中的所有保存的文件，那么你必须使用DIR（）命令来获取文件列表（及其path）。 用于示例代码的Google Excel VBA Dir。

为Target和Source工作簿和工作表设置单独的variables，以便在循环中使用：Dim sWS as worksheet dim tWS as worksheet dim sWB as workbook dim tWB as workbook dim sRange as range dim lRow as long

 'use dir command to locate the first source workbook lrow = tws.usedrange.rows.count + 1 'open the first workbook set swb = workbooks.open(filename) for each sws in swb.sheets set srange = sws.usedrange 'copy from source to next available cell srange.copy tws.Range("A" & lRow) lrow = tws.usedrange.rows.count + 1 next sws 

这会将每个工作簿中的每个选项卡以tws的forms复制到下一个可用的行。