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

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

I found something here:

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

CodePudding user response：

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