我目前是 VBA 的新手，我遇到的问题需要该领域的专家。所以我有一个名为 Archive 的 Masterfile 和 Extract 按钮，我在一个文件夹中有多个 excel 工作簿（20+）。我想从这些工作簿中复制特定信息并将其粘贴到我的主文件中，并连续粘贴到下一个空白单元格中。
不知道什么不起作用，希望有人能在这方面帮助我。 =(
Sub CopyRows()
' Source
Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files - Copy\"
Const sFilePattern As String = "*.xlsm*"
Const sName As String = "Sheet1"
'Const sAddress As String = "B9:N9"
' Destination
Const dCol As String = "B"
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sFilePattern _
& "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = Sheet4.Parent
Dim dFileName As String: dFileName = dwb.Name
Dim dCell As Range
'Dim drg As Range
'Set drg = dCell.Resize(, Sheet4.Range(sAddress).Columns.Count)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
'Dim srg As Range
Dim fCount As Long
fCount = 0
Do Until Len(sFileName) = 0
If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
Set swb = Workbooks.Open(sFolderPath & sFileName)
On Error Resume Next ' attenpt to reference the source worksheet
Set sws = swb.Worksheets(sName)
On Error GoTo 0
If Not sws Is Nothing Then
Set dCell = Sheet1.Cells(SProd.Rows.Count, dCol).End(xlUp).Offset(1)
With sws.Range("B8" & sws.Range("B:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row)
.AutoFilter 8, "Funded"
On Error Resume Next
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy dCell
On Error GoTo 0
fCount = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 + fCount
.AutoFilter
End With
' source worksheet found
'Set srg = sws.Range(sAddress)
' Either copy values, formulas, formats...
'srg.Copy drg
' ... or instead copy only values (more efficient (faster))
'drg.Value = srg.Value
'Set drg = drg.Offset(1)
Set sws = Nothing
Else ' source worksheet not found; do nothing
End If
swb.Close SaveChanges:=False
End If
sFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Rows copied: " & fCount, vbInformation
End Sub回答1
从多个工作簿复制行范围
Sub CopyRows()
' Source
Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files\"
Const sFilePattern As String = "*.xls*"
Const sName As String = "Sheet1"
Const sAddress As String = "B9:N9"
' Destination
Const dCol As String = "A"
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sFilePattern _
& "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = Sheet1.Parent
Dim dFileName As String: dFileName = dwb.Name
Dim dCell As Range
Set dCell = Sheet1.Cells(Sheet1.Rows.Count, dCol).End(xlUp).Offset(1)
Dim drg As Range
Set drg = dCell.Resize(, Sheet1.Range(sAddress).Columns.Count)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim fCount As Long
Do Until Len(sFileName) = 0
If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
Set swb = Workbooks.Open(sFolderPath & sFileName)
On Error Resume Next ' attenpt to reference the source worksheet
Set sws = swb.Worksheets(sName)
On Error GoTo 0
If Not sws Is Nothing Then ' source worksheet found
Set srg = sws.Range(sAddress)
' Either copy values, formulas, formats...
srg.Copy drg
' ... or instead copy only values (more efficient (faster))
'drg.Value = srg.Value
Set drg = drg.Offset(1)
Set sws = Nothing
fCount = fCount + 1
'Else ' source worksheet not found; do nothing
End If
swb.Close SaveChanges:=False
End If
sFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Rows copied: " & fCount, vbInformation
End Sub