VBA to import selective columns by name

[aldenes]

Hello All,

I have 2 files in the same folder: source and destination files. The source files contains more columns than the destination files.
I need to import only selective columns from source to the destination where columns and all their contents will be placed in a different order. The order of columns in the source changes frequently; therefore I need to be able to import the columns based on searching the header than indicating a certain column number position in the destination. I want to write a VBA that would be triggered from the destination file without the source file opened.
Your bright minded people help would be highly appreciated.

 

[John_w]

Try this macro, changing the file name of the source workbook where indicated.

Option Explicit

Public Sub Import_Source_File_Columns()

    Dim sourceWb As Workbook, sourceSheet As Worksheet
    Dim col As Long
    Dim foundCol As Variant
    
    Set sourceWb = Workbooks.Open(ThisWorkbook.Path & "\Source workbook.xlsx")  'CHANGE THIS
    Set sourceSheet = sourceWb.Worksheets(1)
    
    With ThisWorkbook.Worksheets(1)
        For col = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            foundCol = Application.Match(.Cells(1, col).Value, sourceSheet.Rows(1), 0)
            If Not IsError(foundCol) Then
                sourceSheet.Columns(foundCol).Copy .Columns(col)
            Else
                MsgBox "Destination column heading '" & .Cells(1, col).Value & "' not found in row 1 of Source workbook sheet " & sourceSheet.Name
            End If
        Next
    End With

    sourceWb.Close SaveChanges:=False
    
End Sub

 

[mohadin]

What about

Sub Sle_col()
Dim a, Hed  As Variant
Dim lr, x, i As Long
Dim dic As Object
Dim wbk As Workbook
Dim rng As Range
Dim k As Variant
   
With Sheets(1).Cells(1).CurrentRegion
        Hed = Application.Transpose(Application.Transpose(Cells(1, 1).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column)))
        .Offset(1).ClearContents
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Hed)
        If Not dic.exists(Hed(i)) Then
            dic.Add Hed(i), dic.Count + 1
        End If
    Next
    ReDim a(1 To dic.Count)
    Set wbk = Workbooks.Open(ActiveWorkbook.Path & "\Source.xlsx")
    With Sheets("EDRSScheduling")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        x = 1
        Set rng = .Cells(1, 1).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column)
        rng.Select
        For Each k In dic.keys
            a(x) = Application.Transpose(.Cells(1, Application.Match(k, rng, 0)).Offset(1).Resize(lr))
            x = x + 1
        Next
        Workbooks("Source.xlsx").Close False
    End With
    Cells(2, 1).Resize(lr, UBound(a, 1)) = Application.Transpose(a)
End Sub