我正在寻找一些复杂的东西。我有一本主工作簿(名称:Verificari CE),其他工作簿位于桌面上的同一文件夹中(文件夹名称Verificari)。如果我可以从名为“ Verificari”的桌面上的该文件夹中循环遍历整个.xls工作簿,然后将每个工作簿中的数据复制到该主工作簿(Verificari CE)中。
假设我有这些工作簿:
注意:这些工作簿的名称和编号(测试A;测试B;测试C…。)将有所不同!
这是我需要它起作用的方式:
很抱歉,我无法上传示例(我在一家对数据敏感的公司工作)。任何帮助将不胜感激!
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
答案 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
'''