Copy specific data from all MS excel files in the directory in correct order

Question

I would like to extract data from the files located in the directory, but in the correct order.

I found something here:

https://www.mrexcel.com/board/threads/copy-data-specific-data-for-all-files-within-directory-and-consolidate-in-master-file.994203/

https://www.mrexcel.com/board/threads/copy-data-specific-data-for-all-files-within-directory-and-consolidate-in-master-file.994203/

and tried to develop something for my situation

Defining just part of the string as a constant

Object variable or with variable not set for copying

 Sub CopyData()
 Dim wbSource As Workbook
 Dim datSource As Worksheet
 Dim strFilePath, strfile As String
 Dim strPath As String

 Set datTarget = ThisWorkbook.Sheets("Survey")
 strPath = GetPath

 If Not strPath = vbNullString Then

 strfile = Dir$(strPath & "*.xlsx", vbNormal)

 Do While Not strfile = vbNullString

 Set wbSource = Workbooks.Open(strPath & strfile)
 Set datSource = wbSource.Sheets("Sheet1")

 Call Copy_Data(datSource, datTarget)

 wbSource.Close False
 strfile = Dir$()
 Loop
 End If
 End Sub

 Sub Copy_Data(ByRef datSource As Worksheet, datTarget As Worksheet)

 'QUESTION 1


 Const TM_PM As String = "*PM is required*"

 Dim que1 As Range
 Dim ans1 As Range
 Set que1 = Sheets("Sheet1").Range("A1:A100").Find(What:=TM_PM, _
                                     Lookat:=xlPart, LookIn:=xlValues)
                                     
 Dim lrow1 As Long

 lrow1 = datTarget.Range("E" & datTarget.Rows.Count).End(xlUp).Row + 1


 If Not que1 Is Nothing Then
  que1.Copy
 datTarget.Range("E1").PasteSpecial xlPasteValuesAndNumberFormats
 que1.Offset(1).Copy
 datTarget.Range("E" & lrow1).PasteSpecial xlPasteValuesAndNumberFormats
 End If


'QUESTION 2

Const LID_LIFTED As String = "*be lifted*"

Dim que2 As Range
Dim ans2 As Range
Set que2 = Sheets("Sheet1").Range("A1:A100").Find(What:=LID_LIFTED, _
                                     Lookat:=xlPart, LookIn:=xlValues)
                                     

Dim lrow2 As Long

lrow2 = datTarget.Range("F" & datTarget.Rows.Count).End(xlUp).Row + 1

If Not que2 Is Nothing Then
que2.Copy
datTarget.Range("F1").PasteSpecial xlPasteValuesAndNumberFormats
que2.Offset(1).Copy
datTarget.Range("F" & lrow2).PasteSpecial xlPasteValuesAndNumberFormats
End If

'QUESTION 4

Const RAG_STATUS As String = "*RAG Status*"

Dim que4 As Range
Dim ans4 As Range

Set que4 = Sheets("Sheet1").Range("A1:A100").Find(What:=RAG_STATUS, _
                                     Lookat:=xlPart, LookIn:=xlValues)
                                     
Dim lrow4 As Long

lrow4 = datTarget.Range("H" & datTarget.Rows.Count).End(xlUp).Row + 1
                                     
If Not que4 Is Nothing Then
que4.Copy
datTarget.Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
que4.Offset(1).Copy
datTarget.Range("H" & lrow4).PasteSpecial xlPasteValuesAndNumberFormats
End If


End Sub

The results keep coming nicely, but it seems like with no order at all. Some documents don't have certain records, which can be seen in the image. However, the blank spaces should be somewhere in the middle. How can I fix it?

UPDATE: Sheet1 attached

Answer 1

Record the filename of the source data workbook in a spare column and then sort the data on it at the end.

Sub CopyData()

     Const COL_SORT = "K"

     Dim wbSource As Workbook, datSource As Worksheet
     Dim datTarget As Worksheet
       
     Dim strFilePath, strfile As String
     Dim strPath As String, n As Long
    
     Set datTarget = ThisWorkbook.Sheets("Survey")
     strPath = GetPath
     
     Application.ScreenUpdating = False
     If Not strPath = vbNullString Then
    
         strfile = Dir$(strPath & "Z*.xlsx", vbNormal)
         Do While Not strfile = vbNullString
            
             ' parse file for data
             Set wbSource = Workbooks.Open(strPath & strfile, ReadOnly:=True)
             Set datSource = wbSource.Sheets("Sheet1")
             Call Copy_Data(datSource, datTarget, COL_SORT)
            
             wbSource.Close False
             strfile = Dir$()
             n = n + 1
         Loop
         
     End If
     
     ' sort result
     With datTarget
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=.Cells(1, COL_SORT), _
           SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange datTarget.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    Application.ScreenUpdating = True
     
    MsgBox n & " files processed", vbInformation
 End Sub

 Sub Copy_Data(ByRef datSource As Worksheet, datTarget As Worksheet, ColSort As String)

    'QUESTION 1,2,4
    Dim qu(4), q As Long, c As Long
    qu(1) = "*PM is required*"
    qu(2) = "*be lifted*"
    qu(3) = ""
    qu(4) = "*RAG Status*"
    
    Dim rngSearch As Range, rngFound As Range
    Dim lrow As Long
    With datSource
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rngSearch = datSource.Range("A1:A" & lrow)
    End With
    
    ' qu 1,2,4
    For q = 1 To 4
        c = q + 4 ' Q1=E, Q2=F etc
        If qu(q) <> "" Then 'skip qu 3
            
            Set rngFound = rngSearch.Find(What:=qu(q), Lookat:=xlPart, LookIn:=xlValues)
            With datTarget
                lrow = .Cells(.Rows.Count, c).End(xlUp).Row + 1
                If rngFound Is Nothing Then
                    .Cells(lrow, c) = "Not Found" ' blank
                Else
                    rngFound.Copy
                    .Cells(1, c).PasteSpecial xlPasteValuesAndNumberFormats
                     
                    rngFound.Offset(1).Copy
                    .Cells(lrow, c).PasteSpecial xlPasteValuesAndNumberFormats
                End If
                .Cells(lrow, ColSort) = datSource.Parent.Name
            End With
                
        End If
    Next

End Sub