Sub kTest()
Dim FName As String
Dim Fldr As String
Dim i As Long
Dim ka, k(), n As Long
Dim wbkM As Workbook
Dim wbkS As Workbook
Dim wksM As Worksheet
Dim wksS As Worksheet
Dim dic As Object
Dim Hdr, c As Long
Fldr = "C:Qustionnaires" '<<< adjust the folder path
If Right$(Fldr, 1) <> Application.PathSeparator Then Fldr = Fldr & Application.PathSeparator
Set wbkM = ThisWorkbook
Set wksM = wbkM.Worksheets(1)
Hdr = wksM.Range("a1").CurrentRegion.Rows(1).Value2
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
If IsArray(Hdr) Then
For i = 1 To UBound(Hdr, 2)
If Len(Hdr(1, i)) Then dic.Item(Hdr(1, i)) = i
Next
Else
dic.Item("Name") = 1
dic.Item("Age") = 2
dic.Item("Gender") = 3
dic.Item("Religion") = 4
End If
c = dic.Count
ReDim k(1 To 1000, 1 To IIf(c, c, 8))
FName = Dir(Fldr & "*.xls*")
Application.ScreenUpdating = 0
Do While FName <> vbNullString
If FName <> wbkM.Name Then
Set wbkS = Workbooks.Open(Fldr & FName)
Set wksS = wbkS.Worksheets(1)
ka = wksS.Range("a1:c" & wksS.Range("a" & wksS.Rows.Count).End(3).Row)
Set wksS = Nothing
wbkS.Close 0
Set wbkS = Nothing
n = n + 1
k(n, 1) = ka(4, 2): k(n, 2) = ka(5, 2)
k(n, 3) = ka(6, 2): k(n, 4) = ka(7, 2)
For i = 10 To UBound(ka, 1)
If Len(ka(i, 2)) Then
If dic.exists(ka(i, 2)) Then
c = dic.Item(ka(i, 2))
k(n, c) = ka(i, 3)
Else
dic.Item(ka(i, 2)) = dic.Count + 1
c = dic.Count
ReDim Preserve k(1 To 1000, 1 To c)
k(n, c) = ka(i, 3)
End If
End If
Next
Erase ka
End If
FName = Dir()
Loop
If n Then
With wksM
.Range("a1").Resize(, dic.Count) = dic.keys
.Range("a" & .Rows.Count).End(3).Offset(1).Resize(n, dic.Count) = k
.UsedRange.EntireColumn.AutoFit
End With
End If
Application.ScreenUpdating = 1
End Sub