TestCode

Option Explicit
Sub Get_Result1()
    Dim obj_fso As Object
    Dim obj_folder As folder
    Dim obj_file As file
    Dim wb As Workbook
    Dim cel As Range
    Dim strArray() As String

    Dim uMsg As String
    Dim shtName As String
    Dim shtTemp As String
    Dim pRef As String
    Dim fldr As String

    Dim lRw As Long
    Dim nRw As Long
    Dim iNum As Integer
    
    Dim tempstr As String
    
    Application.ScreenUpdating = False
    Set obj_fso = CreateObject("Scripting.FileSystemObject")
    
    shtName = "Result_1"
    shtTemp = "TempSheet"
    With ThisWorkbook
        On Error Resume Next
        Application.DisplayAlerts = False
        .Sheets(shtTemp).Delete
        Application.DisplayAlerts = False
        On Error GoTo 0
        .Sheets.Add.Name = shtTemp
    End With
        With ThisWorkbook.Sheets(shtTemp)
            .Range("A1").Value = "FileName"
            .Range("B1").Value = "SheetName"
            .Range("C1").Value = "Pro ref No"
            .Range("D1").Value = "Std Ref No"
            .Range("E1").Value = "App Type"
'Horizontal
fldr = "E:\Dropbox\Project\Yasin\Task2\Horizontal\"
            Set obj_folder = obj_fso.GetFolder(fldr)
            For Each obj_file In obj_folder.Files
                Debug.Print obj_file
                DoEvents
                Set wb = Workbooks.Open(obj_file)
                lRw = wb.ActiveSheet.Range("E1000000").End(xlUp).Row
                nRw = wb.ActiveSheet.Range("A1000000").End(xlUp).Row
                If lRw < 18 Then GoTo nextfile
                If nRw < 18 Then GoTo nextfile
                If nRw > lRw Then lRw = nRw ' Transfer Max Value in  lRw
                nRw = Application.WorksheetFunction.CountA(.Range("A:A")) + 1
                .Range("A" & nRw & ":A" & lRw - 18 + nRw).Value = wb.Name
                .Range("B" & nRw & ":B" & lRw - 18 + nRw).Value = wb.ActiveSheet.Name
                wb.ActiveSheet.Range("A18:A" & lRw).Copy .Range("C" & nRw)
                wb.ActiveSheet.Range("E18:E" & lRw).Copy .Range("D" & nRw)
                .Range("E" & nRw & ":E" & lRw - 18 + nRw).Value = "Horizontal"
nextfile:
                wb.Close False
            Next
'Application
fldr = "E:\Dropbox\Project\Yasin\Task2\Application\"
            Set obj_folder = obj_fso.GetFolder(fldr)
            For Each obj_file In obj_folder.Files
                Debug.Print obj_file
                DoEvents
                Set wb = Workbooks.Open(obj_file)
                lRw = wb.ActiveSheet.Range("G1000000").End(xlUp).Row
                nRw = wb.ActiveSheet.Range("I1000000").End(xlUp).Row
                If lRw < 2 Then GoTo nextfile1
                If nRw < 2 Then GoTo nextfile1
                If nRw > lRw Then lRw = nRw ' Transfer Max Value in  lRw
                nRw = Application.WorksheetFunction.CountA(.Range("A:A")) + 1
                 .Range("A" & nRw & ":A" & lRw - 2 + nRw).Value = wb.Name
                .Range("B" & nRw & ":B" & lRw - 2 + nRw).Value = wb.ActiveSheet.Name
                wb.ActiveSheet.Range("G2:G" & lRw).Copy .Range("D" & nRw)
                wb.ActiveSheet.Range("I2:I" & lRw).Copy .Range("C" & nRw)
                .Range("E" & nRw & ":E" & lRw - 2 + nRw).Value = "Application"
nextfile1:
                wb.Close False
            Next
            nRw = Application.WorksheetFunction.CountA(.Range("A:A"))
            .Range("C2:D" & nRw).UnMerge
            .Range("$A$1:$E$" & nRw).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
            nRw = Application.WorksheetFunction.CountA(.Range("A:A"))
            .Range("A1:E1").Copy .Range("K1")
            For Each cel In .Range("$A$2:$A$" & nRw)
                DoEvents
                If IsEmpty(cel.Offset(, 3)) Then GoTo nextcel
                strArray = Split(cel.Offset(, 3).Text, Chr(10))
                'Reading Merged Data
                For iNum = LBound(strArray) To UBound(strArray) '- 1
                    DoEvents
                    lRw = Application.WorksheetFunction.CountA(.Range("K:K")) + 1
                    .Range("K" & lRw).Value = cel.Text
                    .Range("L" & lRw).Value = cel.Offset(, 1).Text
                    .Range("M" & lRw).Value = cel.Offset(, 2).Text
                    .Range("N" & lRw).Value = strArray(iNum)
                    .Range("O" & lRw).Value = cel.Offset(, 4).Text
                Next
nextcel:
            Next
             lRw = Application.WorksheetFunction.CountA(.Range("K:K"))
            .Range("J2:J" & lRw).FormulaR1C1 = "=RIGHT(RC[1],LEN(RC[1])-FIND(""-"",RC[1]))"
            .Calculate
            .Range("K2:K" & lRw).Value = .Range("J2:J" & lRw).Value
            .Range("K:K").Replace ".xlsx", "", xlPart
            '.Range("K:K").Replace "*-", "", xlPart
            .Range("K:K").Replace " ", "", xlPart
            .Range("N:N").Replace "A.", "", xlPart
            .Range("N:N").Replace " ", "", xlPart
            .Range("M:M").Replace "Copy of ", "", xlPart
            .Range("M:M").Replace " ", "", xlPart
            lRw = Application.WorksheetFunction.CountA(.Range("K:K"))
            .Range("K1:O" & lRw).RemoveDuplicates Columns:=Array(1, 3, 4), Header:=xlYes
 
            
            lRw = Application.WorksheetFunction.CountA(.Range("K:K"))
            .Range("N1:N" & lRw).Copy .Range("P1")
            .Range("P:P").TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("P1:P" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("Q1:Q" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("R1:R" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("K1:R" & lRw)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
       
        tempstr = ""
        For Each cel In .Range("N2:N" & lRw)
            Debug.Print cel.Value & "--" & cel.Offset(1) & "----" & tempstr
            cel.Select
            If cel.Value = cel.Offset(1) Then
                If cel.Offset(, 1) = "Horizontal" Then
                    If InStr(1, tempstr, cel.Offset(, -3).Text & ",") <= 0 Then
                        tempstr = tempstr & cel.Offset(, -3).Text & ", "
                    End If
                ElseIf cel.Offset(, 1) = "Application" Then
                    If InStr(1, tempstr, cel.Offset(, -1).Text & ",") <= 0 Then
                        tempstr = tempstr & cel.Offset(, -1).Text & ", "
                    End If
                End If
            ElseIf cel.Value <> cel.Offset(1) Then
                If cel.Offset(, 1) = "Horizontal" Then
                    If InStr(1, tempstr, cel.Offset(, -3).Text & ",") <= 0 Then
                        tempstr = tempstr & cel.Offset(, -3).Text & ", "
                    End If
                ElseIf cel.Offset(, 1) = "Application" Then
                    If InStr(1, tempstr, cel.Offset(, -1).Text & ",") <= 0 Then
                        tempstr = tempstr & cel.Offset(, -1).Text & ", "
                    End If
                End If
                nRw = Application.WorksheetFunction.CountA(.Range("AA:AA")) + 1
                .Range("AA" & nRw).Value = cel.Text
                'Debug.Print Right(tempstr, Len(tempstr) - 2)
                .Range("AB" & nRw).Value = Left(tempstr, Len(tempstr) - 2)
                tempstr = ""
            End If
        Next
               
        With .Cells.Font
            .Name = "Calibri Light"
            .Size = 9
        End With
        .Cells.EntireColumn.AutoFit
    End With
    
    With ThisWorkbook.Sheets(shtName)
        lRw = .Range("A100000").End(xlUp).Row
        .Range("F2:F" & lRw).FormulaR1C1 = "=IFERROR(VLOOKUP(C[-4],TempSheet!C[21]:C[24],2,0),"""")"
        .Calculate
        .Range("F2:F" & lRw).Value = .Range("F2:F" & lRw).Value
    End With
    
    'Delete TempSheet
    On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(shtTemp).Delete
        Application.DisplayAlerts = False
    On Error GoTo 0
    

endfunction:
    Application.ScreenUpdating = True
    Set obj_file = Nothing
    Set obj_folder = Nothing
    Set obj_fso = Nothing
    Set wb = Nothing
    Set cel = Nothing
    MsgBox "Report Completed!!!"
End Sub


Sub Get_Result2()
    Dim obj_fso As Object
    Dim obj_folder As folder
    Dim obj_file As file
    Dim wb As Workbook
    Dim cel As Range
    Dim strArray() As String

    Dim uMsg As String
    Dim shtName As String
    Dim pRef As String

    Dim lRw As Long
    Dim nRw As Long
    Dim iNum As Integer
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .AllowMultiSelect = False
'        .InitialFileName = "E:\Dropbox\Project\Yasin\Task2\Horizontal\"
'        If .Show <> -1 Then
'            uMsg = "No Folder Selected"
'            GoTo endfunction
'        End If
'        fpath = .SelectedItems(1)
'    End With
    shtName = "E:\Dropbox\Project\Yasin\Task2\Horizontal\" ' Temp Use of Variable
    Application.ScreenUpdating = False
    Set obj_fso = CreateObject("Scripting.FileSystemObject")
    Set obj_folder = obj_fso.GetFolder(shtName)
    shtName = "Result_2"
    With ThisWorkbook
        On Error Resume Next
        Application.DisplayAlerts = False
        .Sheets(shtName).Delete
        Application.DisplayAlerts = False
        On Error GoTo 0
        .Sheets.Add.Name = shtName
        With .Sheets(shtName)
            .Range("A1").Value = "ID No."
            .Range("B1").Value = "Horizontal"
            .Range("C1").Value = "Assessment question"
            For Each obj_file In obj_folder.Files
                DoEvents
                Set wb = Workbooks.Open(obj_file)
                lRw = wb.ActiveSheet.Range("E100000").End(xlUp).Row
                If lRw < 18 Then GoTo nextfile
                For Each cel In wb.ActiveSheet.Range("E18:E" & lRw)
                    DoEvents
                    pRef = cel.Offset(, -4).Text
                    strArray = Split(cel.Text, Chr(10))
                    For iNum = LBound(strArray) To UBound(strArray) '- 1
                        nRw = Application.WorksheetFunction.CountA(.Range("A:A")) + 1
                        .Range("A" & nRw).Value = strArray(iNum)
                        .Range("B" & nRw).Value = obj_file.Name
                        .Range("C" & nRw).Value = pRef
                    Next
                Next
nextfile:
                wb.Close False
            Next
            
                .Range("B:B").Replace ".xlsx", "", xlPart
                .Range("B:B").Replace "*-", "", xlPart
                .Range("B:B").Replace " ", "", xlPart
                .Range("A:A").Replace "A.", "", xlPart
                .Range("A:A").Replace " ", "", xlPart
                
                lRw = Application.WorksheetFunction.CountA(.Range("A:A"))
                .Range("A1:A" & lRw).Copy .Range("D1")
                .Range("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                    :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("D2:D" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=Range("E2:E" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=Range("F2:F" & lRw), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With .Sort
                    .SetRange Range("A1:F" & lRw)
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                .Range("D:F").Delete
                .Range("A:C").HorizontalAlignment = xlCenter
                .Range("A:C").EntireColumn.AutoFit
        End With
    End With
endfunction:
    Application.ScreenUpdating = True
    Set obj_file = Nothing
    Set obj_folder = Nothing
    Set obj_fso = Nothing
    Set wb = Nothing
    Set cel = Nothing
    MsgBox "Report Completed!!!"
End Sub



 .Range("B2:B" & lRw).TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
        :=".", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

Total Page Visits: 173 - Today Page Visits: 2