當談到 VBA 時，我目前是新手，我遇到了需要該領域專家的問題。所以我有一個名為 Archive 的 Masterfile 和 Extract 按鈕，我在一個檔案夾中有多個 excel 作業簿（20 ）。我想從這些作業簿中復制特定資訊并將其粘貼到我的主檔案中，并連續粘貼到下一個空白單元格中。
不知道什么不起作用，希望有人能在這方面幫助我。=(
Sub loopthru()
Dim MyFile As String
Dim erow
Dim rw As Range
Dim MyFile As Worksheet
Dim r As Long
MyFile = Dir("C:\Users\ChrisLacs\Desktop\My Files\")
Set rw = MyFile.Rows(r)
Do While Len(MyFile) > 0
If MyFile = "Archive.xlsm" Then
Exit Sub
End If
If rw.Columns("J").Value = "Apple" Then
Workbooks.Open (MyFile)
Range("B9:N9").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 13))
MyFile = Dir
Loop
End If
uj5u.com熱心網友回復：
從多個作業簿復制行范圍
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/474710.html
上一篇：JAVA的型別轉換（基本型別）