遍历多个工作簿并复制到另一个现有工作簿

Question

我正在寻找一些复杂的东西。我有一个主工作簿（名称：Verificari CE），其他工作簿位于桌面上的同一文件夹中（文件夹名称 Verificari）。如果我可以从位于桌面上名为“Verificari”的文件夹中循环遍历整个 .xls 工作簿，并将每个工作簿中的数据复制到这个主工作簿 (Verificari CE) 中。

假设我有这些工作簿：

• Verificari CE（主工作簿）
• 测试 A
• 测试 B
• 测试 C

注意：这些工作簿的名称和编号（测试 A；测试 B；测试 C……）会有所不同！

这是我需要它的功能：

• 将测试 A 的 Sheet1 中包含数据的所有行复制到 Verificari CE。
• 然后 检查测试 B 的 Sheet1 并复制所有包含 A2 数据的行，在 Verificari CE 上粘贴以下活动 A 的数据
• 然后 检查测试 C 的 Sheet1 并复制所有包含数据的行，在 Verificari CE 上粘贴以下活动 B 的数据

很抱歉，我无法上传示例（我在一家对数据敏感的公司工作）。任何帮助将不胜感激！

Sub Copymultiple()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Dim VerificariCE As Workbook
    Dim TestA As Workbook
    Dim TestB As Workbook
    Dim TestC As Workbook

    Dim maxRow As Long
    Dim maxCol As Integer

    Dim nextRow As Long

    Set VerificariCE = Workbooks("Verificari CE.xlsm")

    With VerificariCE.Sheets(2)   
        Workbooks.Open .Cells(1, 1).Value
        Set TestA = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestB = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestC = ActiveWorkbook
    End With

    'Comment this out if you don't want to clear existing values
    VerificariCE.Sheets(1).UsedRange.Clear
    'Comment this out if you don't want to clear existing values

    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    With TestA.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestA.Close

    With TestB.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestB.Close

    With TestC.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestC.Close

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With

    With VerificariCE.Sheets(1).UsedRange
        .Value = .Value
        .Activate
    End With

    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

Answer 1

避免使用选择。使用对象变量指向您的对象。使用 DIR 读取文件夹中的文件。

Sub Example()
const foldername = "Verificari"
const mastername = "Verificari CE.xlsm"
Dim wb as workbook
Dim ws as Worksheet
Dim targetbook as workbook
Set targetbook = workbooks(mastername) 'I assume this code is in this file and it is therefore open
Dim targetsheet as worksheet
set targetsheet = worksheets(1) 'assume first sheet
Dim target as range
set target = targetsheet.range("a2")
Dim r as range
Dim s as string
s = dir(foldername & "*.xl*")  'read spreadsheet names
do while s <> ""
   if s = mastername then
   else
   set wb = workbooks.open(foldername & "\" & s)
   if not wb is nothing then
      set ws = wb.worksheets(1)
     '#########
      set r = targetsheet.range("a" & rows.count).end(xlup).offset(1,0)
      ws.usedrange.copy r
      '##########
      wb.close false
   end if
   end if   'missed this first time round
   s = dir()
loop
end sub

我无法测试，所以可能有错别字

Answer 2

这是我过去使用过的实用程序。它有一些前端可以让您选择要合并的文件，但它应该为您提供您正在寻找的代码。祝你好运！

Public FirstRowUsed As Integer
Sub CreateInputFile()

Dim fs, f, s
Dim PathInfo As Variant
Dim TrueVar As Variant
Dim FileToOpen() As Variant

'screen.mousepointer = fmMousePointerHourglass
Application.Cursor = xlWait
FirstRowUsed = 3
LastRowUsed = ActiveSheet.UsedRange.Rows.Count
If LastRowUsed >= FirstRowUsed Then
  ClearSheet = MsgBox("Clear Sheet?", vbOKCancel, "Current Data will be deleted")

  If ClearSheet = 1 Then
    x = Range(Cells(FirstRowUsed, 1), Cells(ActiveSheet.UsedRange.Rows.Count, 1)).Select
    Selection.EntireRow.Delete
    x = Range(Cells(FirstRowUsed, 1), Cells(FirstRowUsed, 1)).Select
    Selection.Activate
  Else
    x = MsgBox("Process Terminated, No Action Taken.", vbOKOnly)
    GoTo CreateInputFileExit
  End If
End If

TrueVar = True
FileToOpen = Application _
    .GetOpenFilename("Excel Files (*.xls;*.xlsx),*.xls;*.xlsx,(*.xlsx),*.xlsx", , "Select Files to Combine", , TrueVar)

On Local Error Resume Next

If UBound(FileToOpen) < 1 Then
  x = MsgBox("Process Terminated", vbOKOnly)
  GoTo CreateInputFileExit
Else
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set FileInfo = fs.GetFile(FileToOpen(1))
  TargetPath = fs.GetParentFolderName(FileToOpen(1))
End If

On Local Error GoTo 0

Set PathInfo = fs.Getfolder(TargetPath)

TargetPath = PathInfo.shortpath

Application.StatusBar = False

On Local Error Resume Next

Call GetFileInfo(FileToOpen())

Application.StatusBar = False
Application.ScreenUpdating = True
SendKeys "^{HOME}"  'Ctrl+Home

CreateInputFileExit:

  Application.Cursor = xlDefault

End Sub

Sub GetFileInfo(FileToOpen() As Variant)

Dim Row As Double
Dim FileCtr As Double
Dim ReportInterval As Double
Dim fs, f, s
Dim FileInfo As Variant
Dim Ext As String

On Local Error Resume Next

Set fs = CreateObject("Scripting.FileSystemObject")


Row = FirstRowUsed
ReportInterval = 100
FileCtr = 0
For i = 1 To UBound(FileToOpen)

  TotFileName = FileToOpen(i)

  DirCheck = Dir(TotFileName)
  DateOut = FileDateTime(TotFileName)
  FileLength = FileLen(TotFileName)

  If DirCheck > "" Then ' Eliminates Directory entries

    Set FileInfo = fs.GetFile(TotFileName)
    Ext = fs.GetExtensionName(TotFileName)
    Pathname = fs.GetParentFolderName(TotFileName)

    Filename = FileInfo.Name
    Cells(Row, 1) = Pathname
    Cells(Row, 2) = Filename
    Cells(Row, 3) = DateOut
    Cells(Row, 4) = FileLength
    Cells(Row, 5) = TotFileName
    Cells(Row, 6) = Ext
    Row = Row + 1
    FileCtr = FileCtr + 1


    If FileCtr Mod ReportInterval = 0 Then
      DoEvents
      Application.ScreenUpdating = True
      Cells(Row - 1, 1).Activate 'Makes the screen change a bit so the user knows it is working
      Application.ScreenUpdating = False
      Application.StatusBar = "File Names Processed so far: " & FileCtr
    End If

  End If

Next i

Application.StatusBar = False

End Sub

Sub MergeTheFiles()
Dim FileSheet As Worksheet
Dim TargetBook As Workbook
Dim SourceBook As Workbook

FileSheetNm = "FileList"
ActiveWorkbook.Worksheets(FileSheetNm).Activate

Set FileSheet = ActiveSheet
Set Targetworkbook = Workbooks.Add

MaxRow = FileSheet.UsedRange.Rows.Count

Numfiles = MaxRow - 2

For i = 3 To MaxRow
  Sourcefile = FileSheet.Cells(i, 5)
  Workbooks.Open Filename:=Sourcefile, UpdateLinks:=3, ReadOnly:=True

  Set SourceWorkBook = ActiveWorkbook
  TargetDirectory = FileSheet.Cells(i, 1)
  Application.DisplayAlerts = False
  For Each sh In SourceWorkBook.Worksheets
    ShtNm = sh.Name
    LastSheet = Targetworkbook.Worksheets.Count
    sh.Copy After:=Targetworkbook.Sheets(LastSheet)

        Set CurrSht = ActiveWorkbook.Worksheets(LastSheet + 1)
        Set TrgtSht = ActiveWorkbook.Worksheets(1)
        TrgtAddr = Cells(TrgtSht.UsedRange.Rows.Count + 1, 1).Address

    With CurrSht

        lRow = .Cells.Find(What:="*", _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

        lCol = .Cells.Find(What:="*", _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column

        .Range(.Cells(1, 1), .Cells(lRow, lCol)).Copy Destination:=TrgtSht.Range(TrgtAddr)
    End With

    CurrSht.Delete

  Next sh

  Application.DisplayAlerts = True
  SourceWorkBook.Close SaveChanges:=False

Next i


    DateOfFile = Format(Date$, "yyyy-mm-dd")

    TargetFileName = "$Date XYZ"

    TargetFileName = Application.WorksheetFunction.Substitute(TargetFileName, "$Date", DateOfFile)
    fileSaveName = Application.GetSaveAsFilename( _
    InitialFilename:=TargetFileName, _
    fileFilter:="Excel Files (*.xlsx), *.xlsx")
    NewFileNameAndDir = fileSaveName
    If InStr(UCase(NewFileNameAndDir), ".XLS") = 0 Then
      If Right(NewFileNameAndDir, 1) = "." Then
        NewFileNameAndDir = NewFileNameAndDir & "xlsx"
      Else
        NewFileNameAndDir = NewFileNameAndDir & ".xlsx"
      End If
    End If

    ActiveWorkbook.SaveAs Filename:=NewFileNameAndDir, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    With Application
        .Calculation = xlManual
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

   With Application
        .Calculation = xlAutomatic
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

    ActiveWorkbook.Save

End Sub
'''