Copy Data from Multiple Excel files to Mastefile

Question

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 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

Answer 1

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