Extract Data from Multiple Workbooks

[XLacs]

Hello Good People,

I have this simple yet dunno how to solve this problem of mine.

I have a master file and multiple workbooks(20+). In my workbooks column J there is a status dropdown..

If column J status =Working then I it should copy the details of workbooks column B-N and update the column O status to extracted so it will
excluded on my next extraction..

Hoping someone could actually help me on my below code.. =(

>>> You have many times skipped <<<
>>> use code - tags <<<

Sub CopyRows()
   
    ' Source
    Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files\"
    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
    Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
    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
   
    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

 

[Marc L]

I have a master file and multiple workbooks

Hi, as we do not have any so the better is you elaborate at least each step in order there is nothing to guess …​

​