Question

下午，

我正在尝试从多个工作簿中的多个（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

将您的文件夹/文件选择器放在一个单独的功能中，您可以调用该功能返回所选的文件夹。

如果您希望它打开文件夹中的所有已保存文件，则必须使用DIR（）命令获取文件列表（及其路径）。用于示例代码的Google Excel VBA目录。

为目标和源工作簿设置单独的变量，并在循环中使用工作表：将sWS作为工作表将tWS作为工作表昏暗的sWB作为工作簿昏暗的tWB作为工作簿 dim sRange作为范围 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中的下一个可用行。

Answer 2

 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

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

2 个答案: