我在 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 之类的东西)并假设您要从第一张工作表(您打开的工作簿的)复制数据并粘贴到 "Sheet1"
中的 Thisworkbook
,代码可能如下所示。
在运行下面的代码之前复制整个文件夹(包含 .xlsx
文件)可能会很好(不必要,但以防万一)。
如果您有数百个文件要打开,您可能希望在 Application.ScreenUpdating
循环之前和之后切换 For
(以防止不必要的屏幕闪烁和重绘)。
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
关于excel - 如何打开多个工作簿以从中复制数据,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/53989467/