Copy a table Column to another workbook if a column name match is found

[gheyman]

This is a pretty big request and I appreciate the help.

I am looking for VBA code that will

first ask the user to open the workbook where the data is going to be copied to.

Check the opened workbook to ensure it has a tab named "Data"

In the workbook that is being opened the Column Names are in Row 1. (This workbook is not set up as a table.)

In the users Original workbook they will have a tab named "LineCharges" in this tab there is a table named: MSQ_BySE_LineCharges The tables columns names are in Row 5.

If possible I need to go through each column and check to see if it finds a column name match between the original workbook and the one they opened.

If there is an exact name match to the columns I need to copy the table column and paste it into the matching column of the opened workbook starting in row 7

The table can have anywhere between 40-60 columns and sometimes the source where its pasting to may or may not have the same columns and the columns may be in a different order. Something I cant control. This is what makes it a bit to difficult for me to code.

Any help is very much appreciated and I truly appreciate your time.

 

[kevin9999]

Please try the following on a copy of your 'Original' workbook.

Option Explicit
Sub gheyman()
    'Set initial variables
    Dim wbSrc As Workbook, wbDest As Workbook
    Set wbSrc = ThisWorkbook
    Dim wsSrc As Worksheet
    Set wsSrc = wbSrc.Worksheets("LineCharges")
    
    'Open destination workbook
    Dim FileName
    FileName = Application.GetOpenFilename _
    (filefilter:="Excel files (*.xlsx),*.xlsx", Title:="Open destination file", MultiSelect:=False)
    If FileName = False Then Exit Sub
    Set wbDest = Workbooks.Open(FileName)
    
    'Check whether sheet called Data exists in destination file
    Dim wsTest As String: wsTest = "Data"
    With wbDest
        If Evaluate("ISREF('" & wsTest & "'!A1)") Then
            Dim wsDest As Worksheet
            Set wsDest = .Worksheets("Data")
        Else
            MsgBox "The worksheet 'Data' does not exist in this workbook"
            wbDest.Close
            Exit Sub
        End If
    End With
    
    'Loop through table headers & copy if found in destination file
    Dim tblSrc As String, hdrSrc As Range, hdrStr As String, i As Long
    tblSrc = "MSQ_BySE_LineCharges"
    For Each hdrSrc In wsSrc.ListObjects(tblSrc).Range.Rows(1).Cells
        hdrStr = hdrSrc
        On Error Resume Next
        i = WorksheetFunction.Match(hdrStr, wsDest.Rows(1), 0)
        If i > 0 Then
            wsSrc.ListObjects(tblSrc).ListColumns(hdrStr).DataBodyRange.Copy wsDest.Cells(7, i)
        End If
        On Error GoTo 0
    Next hdrSrc
End Sub