I am currently novice when it comes to VBA and I have this problem that requires an expert in this field. So I have a Masterfile Named Archive with Extract button and I have multiple excel workbook (20 ) in a folder. I wanted to copy a specific information from those workbook and paste it to my masterfile contionusly to the next blank cell.

Not sure what is not working, Hoping someone could actually assist me on this. =(

    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

CodePudding user response：

Copy a Row Range From Several Workbooks

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