我用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
答案 0 :(得分：2)
使用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
答案 1 :(得分：2)
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
答案 2 :(得分：0)
这是我最终实现目标的方式：
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