循环浏览多个工作簿并复制到另一个现有工作簿中

时间:2019-03-11 10:23:46

标签: excel vba

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

假设我有这些工作簿:

  • Verificari CE(主工作簿)
  • 测试A
  • 测试B
  • 测试C

注意:这些工作簿的名称和编号(测试A;测试B;测试C…。)将有所不同!

这是我需要它起作用的方式:

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

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

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

1 个答案:

答案 0 :(得分:0)

这是我过去使用的实用程序。它具有一些前端,可让您选择要合并的文件,但它应该为您提供所需的代码。祝你好运!

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
'''