[英]How to copy data from multiple Excel workbooks in a folder into main sheet?
[英]How to open multiple workbooks to copy the data from
我已經在vba中編寫了一個腳本,該腳本能夠從桌面上的特定文件夾導入.xlsx
文件,並從那里復制數據,以便將其粘貼到當前活動的工作表中。 我的腳本對於單個.xlsx
文件運行良好。
該文件夾包含100個.xlsx
文件。 在工作表Sheet1
中的每個文件具有固定固定的數據(行可能有所不同)。
我現在想做的是在我的活動工作表中逐個獲取這些文件中的所有數據( appended one after another in row-wise
) 。
到目前為止我的嘗試:
Sub OpenAndImportFile()
Dim wbO As Workbook, wsI As Worksheet, cel As Range
Set wsI = ThisWorkbook.Worksheets("Sheet1")
Set wbO = Workbooks.Open("C:\Users\WCS\Desktop\files\coworking\list_members-coworking-annkingman-2018-12-31-14-55-07-eisaiah_e.xlsx")
For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
cel(1, 1).EntireRow.Copy wsI.Range(cel(1, 1).Address)
Next cel
wbO.Close SaveChanges:=False
End Sub
使用VBA(而不是Power Query之類的東西),並假設您要從(打開的工作簿的)第一張表中復制數據並粘貼到Thisworkbook
"Sheet1"
中,代碼可能類似於以下內容。
在運行下面的代碼之前,最好制作整個文件夾(包含.xlsx
文件)的副本(不必要,但以防萬一)。
如果要打開數百個文件,則可能要在For
循環之前和之后切換Application.ScreenUpdating
(以防止不必要的屏幕閃爍和重繪)。
Option Explicit
Private Sub CopyPasteSheets()
Dim folderPath As String
folderPath = "C:\Users\WCS\Desktop\files\coworking\"
If Len(VBA.FileSystem.Dir$(folderPath, vbDirectory)) = 0 Then
MsgBox ("'" & folderPath & "' does not appear to be a valid directory." & vbNewLine & vbNewLine & "Code will stop running now.")
Exit Sub
End If
Dim filePathsFound As Collection
Set filePathsFound = New Collection
Dim Filename As String
Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbNormal)
Do Until Len(Filename) = 0
filePathsFound.Add folderPath & Filename, Filename
Filename = VBA.FileSystem.Dir$()
Loop
Dim filePath As Variant ' Used to iterate over collection
Dim sourceBook As Workbook
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called
'destinationSheet.Cells.Clear ' Uncomment this line if you want to clear before beginning
Dim rowToPasteTo As Long
rowToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
If rowToPasteTo > 1 Then rowToPasteTo = rowToPasteTo + 1
For Each filePath In filePathsFound
On Error Resume Next
Set sourceBook = Application.Workbooks.Open(Filename:=filePath, ReadOnly:=True)
On Error GoTo 0
If Not (sourceBook Is Nothing) Then
With sourceBook.Worksheets(1) ' Might be better if you refer to sheet by name rather than index
Dim lastRowToCopy As Long
lastRowToCopy = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A1:A" & lastRowToCopy).EntireRow
If (rowToPasteTo + .Rows.Count - 1) > destinationSheet.Rows.Count Then
MsgBox ("Did not paste rows from '" & sourceBook.FullName & "' due to lack of rows on sheet." & vbNewLine & vbNewLine & "Code will close that particular workbook and then stop running.")
sourceBook.Close
Exit Sub
End If
.Copy destinationSheet.Cells(rowToPasteTo, "A").Resize(.Rows.Count, 1).EntireRow
rowToPasteTo = rowToPasteTo + .Rows.Count
End With
End With
sourceBook.Close
Set sourceBook = Nothing
Else
MsgBox ("Could not open file at '" & CStr(sourceBook) & "'. Will try to open remaining workbooks.")
End If
Next filePath
End Sub
Sub OpenAndImportFile()
' Source File Folder Path
Const cStrFolder As String = "C:\Users\WCS\Desktop\files\coworking"
Const cStrExt As String = "*.xls*" ' Source File Pattern
Const cVntSrcName As Variant = 1 ' Source Worksheet Name/Index
Const cVntSource As Variant = "A" ' Source Column Letter/Number
Const cVntTgtName As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cVntTarget As Variant = "A" ' Target Column Letter/Number
Dim objWbSource As Workbook ' Source Workbook
Dim objRngU As Range ' Source Union Range
Dim StrFile As String ' Source File Name
Dim i As Long ' Source Row Counter
Dim j As Long ' Target Row Counter
Dim objWsTarget As Worksheet ' Target Worksheet
Dim cLngPasteRow As Long ' Target Paste Row
Set objWsTarget = ThisWorkbook.Worksheets(cVntTgtName)
objWsTarget.Cells.Clear
cLngPasteRow = 1
StrFile = Dir(cStrFolder & "\" & cStrExt)
On Error GoTo ProcedureExit
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Do While Len(StrFile) > 0
Set objWbSource = Workbooks.Open(cStrFolder & "\" & StrFile)
With objWbSource.Worksheets(1)
' Debug.Print objWbSource.Name & " " & .Name & " " & cLngPasteRow
If .Cells(.Rows.Count, cVntSource).End(xlUp).Row = 1 _
And .Cells(1, 1) = "" Then
Else
For i = 1 To .Cells(.Rows.Count, cVntSource).End(xlUp).Row
If Not objRngU Is Nothing Then
Set objRngU = Union(objRngU, .Cells(i, cVntSource))
Else
Set objRngU = .Cells(i, cVntSource)
End If
j = j + 1
Next
End If
End With
If Not objRngU Is Nothing Then
objRngU.EntireRow.Copy objWsTarget.Cells(cLngPasteRow, cVntTarget)
Set objRngU = Nothing
cLngPasteRow = j + 1 ' Next row to copy data to.
End If
objWbSource.Close False
StrFile = Dir
Loop
ProcedureExit:
Set objRngU = Nothing
Set objWbSource = Nothing
Set objWsTarget = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
這是我最終實現目標的方式:
Sub OpenAndImportFile()
Dim wbO As Workbook, wsI As Worksheet, cel As Range
Dim daddr$, Filename$, foundfiles As New Collection
Dim xlfile As Variant
Application.ScreenUpdating = False
daddr = Environ("USERPROFILE") & "\Desktop\files\coworking\"
Filename = Dir(daddr & "*.xlsx")
Set wsI = ThisWorkbook.Worksheets("Sheet1")
Do While Len(Filename) > 0
foundfiles.Add Filename
Filename = Dir
Loop
For Each xlfile In foundfiles
Set wbO = Workbooks.Open(daddr & xlfile)
For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
cel(1, 1).EntireRow.Copy wsI.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
Next cel
wbO.Close SaveChanges:=False
Next xlfile
Application.ScreenUpdating = True
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.