Copy specific columns from multiple files in folder and combine those columns in workbook

below is the column header should consider from all the files in the folder

ColumnNameList = Array("Serial No.", "Country", "Domain Owner",  "Overall Status")

otherwise the code could be the list where i can add column headers in other sheet

Hi Jazzer,
My Apologies. I dont know how to move the post from subform. Can you help this post.

I am sharing the multiple files and the file with the code.
Basically i have files in a folders, and columns in all files are random, my code just copy the sheet and paste in to the active worksheet and so on for other files in the folder.
But what i actually want is, copy and paste activity should follow the below column order for all files.
Serial No.
Country
Domain Owner
Other communications
Overall status

I have attached the file with code along with sample files.


I hope you understand, please let me know if unclear. thanks

This will not import the data from the workbook;
1) doesn't have "owssvr" sheet.
2) any column heading missing/doesn't match to heading in destination sheet.

Sub test()
    Dim myDir As String, fn As String, i As Long, s
    Dim cn As Object, rs As Object
    Const wsName As String = "owssvr"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xlsx")
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myDir & fn & ";Extended Properties=""Excel 12.0;"""
    With Sheets("expected output").[a1].CurrentRegion
        .Offset(1).ClearContents
        s = .Parent.Evaluate(.Rows(1).Address & "&""""")
        Do While fn <> ""
            If IsSheetExists("'" & myDir & "[" & fn & "]" & wsName & "'", s) Then
                rs.Open "Select `" & Replace(Join(s, "`, `"), ".", "#") & "` From " & _
                    "`Excel 12.0;DataBase=" & myDir & fn & "`.`" & wsName & "$`;", cn
                .Range("a" & Rows.Count).End(xlUp)(2).CopyFromRecordset rs
                rs.Close
            End If
            fn = Dir
        Loop
    End With
End Sub

Function IsSheetExists(fn, s) As Boolean
    Dim e, x
    If IsError(ExecuteExcel4Macro(fn & "!r1c1")) Then Exit Function
    For Each e In s
        x = ExecuteExcel4Macro("match(""" & e & """," & fn & "!r1:r1,0)")
        If IsError(x) Then Exit Function
    Next
    IsSheetExists = True
End Function

Hi Jindon,
Unfortunately i got 'Mismatch error:13' for the below line

For Each e In s

Like I said earlier in post #9

Originally Posted by jindon

This will not import the data from the workbook;
1) doesn't have "owssvr" sheet.
2) any column heading missing/doesn't match to heading in destination sheet.

Most probably other files would match to above.

If you upload a workbook that is not imported, I can tell.

Are you running from the file I attached?

That error occur when you have no headings in destination sheet.
change "test" sub to

Sub test()
    Dim myDir As String, fn As String, i As Long, s
    Dim cn As Object, rs As Object
    Const wsName As String = "owssvr"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xlsx")
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myDir & fn & ";Extended Properties=""Excel 12.0;"""
    With Sheets("expected output")
        .[a1].CurrentRegion.ClearContents
        s = Array("Serial No.", "Country", "Overall status", "Other communications", "Domain Owner")
        .[a1].Resize(, UBound(s) + 1) = s
        Do While fn <> ""
            If IsSheetExists("'" & myDir & "[" & fn & "]" & wsName & "'", s) Then
                rs.Open "Select `" & Replace(Join(s, "`, `"), ".", "#") & "` From " & _
                    "`Excel 12.0;DataBase=" & myDir & fn & "`.`" & wsName & "$`;", cn
                .Range("a" & Rows.Count).End(xlUp)(2).CopyFromRecordset rs
                rs.Close
            End If
            fn = Dir
        Loop
    End With
End Sub

Hi Jindon,
I have added the column header still is not working.
for the second piece of code, i getting runtime error. It says problem with one or more formula references in this worksheet.
Is the code search for random columns in the attached sheet?

Hi Jindon,
Nothing required, your code works now. I have copied your code in to new workbook, it works now.
Is it possible to have list of column headers in other worksheet, instead of going to module and add? you amend in your first code. thanks so much for your help.

I have tested the code before I posted, so it should work.

In order to avoid any misunderstanding, you'd better to attach the workbook with the header somewhere and the sheet that receives the data.

try change one line in "test" sub

        s = Array("Serial No.", "Country", "Overall status", "Other communications", "Domain Owner")

to

        s = Filter(Sheets("Column header").[transpose(if(a1:a1000<>"",a1:a1000))], False, 0)

Hi Jindon,
I can able to get output only for first 3 workbooks not for remaining workbooks, there could be more than 30+ files in a folder. But the macro picking only 3 files. Do you know why?. i just followed the same procedure for all other files. I do not have any clue. please help. Thanks.

Sub test()
    Dim myDir As String, fn As String, i As Long, s(1)
    Dim cn As Object, rs As Object, x As Long
    Const wsName As String = "owssvr"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xlsx")
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myDir & fn & ";Extended Properties=""Excel 12.0;"""
    With Sheets("expected output")
        .[a1].CurrentRegion.ClearContents
        s(0) = Filter(Sheets("Column header").[transpose(if(a1:a1000<>"",a1:a1000))], False, 0)
        .[a1].Resize(, UBound(s(0)) + 1) = s(0)
        Do While fn <> ""
            s(1) = Cols("'" & myDir & "[" & fn & "]" & wsName & "'", s(0))
            If s(1) <> "" Then
                rs.Open "Select " & s(1) & " From " & _
                    "`Excel 12.0;DataBase=" & myDir & fn & "`.`" & wsName & "$`;", cn
                x = .Evaluate("max(if(" & .[a1].Address & "<>"""",row(" & .[a1].CurrentRegion.Address & ")))")
                .Range("a" & x + 1).CopyFromRecordset rs
                rs.Close
            End If
            fn = Dir
        Loop
    End With
End Sub

Function Cols(fn, s) As String
    Dim e, x, flg As Boolean
    If IsError(ExecuteExcel4Macro(fn & "!r1c1")) Then Exit Function
    For Each e In s
        x = ExecuteExcel4Macro("match(""" & e & """," & fn & "!r1:r1,0)")
        If IsError(x) Then
            Cols = Cols & ", Null"
        Else
            Cols = Cols & ", `" & Replace(e, ".", "#") & "`": flg = True
        End If
    Next
    If Not flg Then Exit Function
    If InStr(Cols, "`") = 3 Then Cols = Mid$(Cols, 3) Else Cols = Mid$(Cols, 2)
End Function