Using VBA to pull in data from separate workbook based on specific column order

[MixMasterMike]

Hi All,

I currently have a macro that copy and pastes data from one workbook to a separate workbook, but it's not dynamic at the moment - meaning that if the column ordering of the source data changes, then the macro will not serve it's original purpose. I have had to maintain the macro in the past and update the code every time that the column ordering of the source data changes, which can be a pain when altering/rearranging the code and making sure that the correct column structure matches the destination workbook. I know some VBA basics, but struggle with more complex scripts. I have include the current code below that I'm utilizing to run the macro (which you will notice is not very efficient), and am hoping to alter or replace it in order to make it dynamic.

Perhaps using VBA Find might work to match the column names and then grab that data under the header when a match is identified? There is over 200 columns of data to pull which all have unique headers so typing in the column name within a Find object would not be feasible - I assume some sort of loop could be used.

Appreciate the help and hope someone can provide some insight on this.

Mike

VBA Code:

Option Explicit

Sub Get_Data_From_File()

'Declare variables'
Dim FileToOpen As Variant
Dim openbook As Workbook

'Disable certain excel features whilst macro is running'
Application.ScreenUpdating = False

'Open disired file to copy data from'
FileToOpen = Application.GetOpenFilename(Title:="Browse for your file and import range", Filefilter:="Excel files (*xls*),*xls*")

If FileToOpen <> False Then
Set openbook = Application.Workbooks.Open(FileToOpen)

'COPY RANGES FROM SELECTED WORKBOOK'
openbook.Sheets("Export data").Range("A:BP").Copy 'INTIAL MATCHING COLUMNS'
ThisWorkbook.Worksheets("DataGrab").Range("A1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("BU:BX").Copy 'VACY PAYOUT & TERMINATION COMBINED'
ThisWorkbook.Worksheets("DataGrab").Range("BQ1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("CC:CR").Copy 'Taxable Accidental Death & Dismemberment Amount Current- Contact Unit YTD'
ThisWorkbook.Worksheets("DataGrab").Range("BU1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("CS:DD").Copy 'ER RRSP Contributions - Taxable Life Unit YTD'
ThisWorkbook.Worksheets("DataGrab").Range("CO1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("DE:DT").Copy 'AUTOMATIC VACATION - 2ND OP Amount YTD'
ThisWorkbook.Worksheets("DataGrab").Range("DM1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("DW:EB").Copy 'Dental Amount Current - Vacation Accrual Amount YTD'
ThisWorkbook.Worksheets("DataGrab").Range("EE1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("EC:EL").Copy '*CO CPP Amount Current - Company Contributions CPP/QPP YTD'
ThisWorkbook.Worksheets("DataGrab").Range("EM1").PasteSpecial xlPasteValues

openbook.Sheets("Export data").Range("DU:DV").Copy 'No Tax RRSP - Employee Amount Current & YTD'
ThisWorkbook.Worksheets("DataGrab").Range("EW1").PasteSpecial xlPasteValues


openbook.Sheets("Export data").Range("EM:HG").Copy 'All WCB columns'
ThisWorkbook.Worksheets("DataGrab").Range("EY1").PasteSpecial xlPasteValues


openbook.Sheets("Export data").Range("BQ:BT").Copy 'Bonus payments column, manually pulled'
ThisWorkbook.Worksheets("DataGrab").Range("HT1").PasteSpecial xlPasteValues

openbook.Close False

End If

Application.ScreenUpdating = True

End Sub

[#2]

@MixMasterMike 

Sub copyandpaste()

Dim h, i, j, k, l As Long

k = Range("A1").End(xlToRight).Column

For i = 1 To k

h = Application.WorksheetFunction.Match(Cells(1, i), Sheets("Tabelle2").Range("1:1"), 0)
j = Sheets("Tabelle2").Range("i" & Rows.Count).End(xlUp).Row

For l = 2 To j
Cells(l, i).Value = Sheets("Tabelle2").Cells(l, h).Value

Next l

Next i

End Sub

You can try this code to pull data based on a specific column number within the same workbook. In the attached file you can click the button in cell L2 to run the macro. If this works for you the code can be adapted in order to pull data from another workbook.

[#3]

Function LjsAdo()
    On Error Resume Next '忽略错误
    Application.ScreenUpdating = False '停止屏幕刷新
    Application.DisplayAlerts = False '关闭报警窗口
    Dim myCN As Object ' 定义连接函数对象
    Dim myRS As Object '定义记录集对象
    Dim FilePath As String, SQLstr As String '定义文件路径和SQL语句变量
    Dim i As Long
    Set myCN = CreateObject("Adodb.Connection")
    '--------------------------------------------------
    FilePath = ThisWorkbook.FullName '定义本表文件名（包含路径）为目标文件路径
    SQLstr = "select format,css_class from [results$]" ' WHERE 姓名 like '%赵%' OR 姓名='马五' AND 年龄>20表名使用中括号加dollar符号表示，标题名称不需要使用引号。
    'SQLstr = "INSERT INTO [DB$] (姓名,年龄,性别,籍贯,备注) VALUES ('阳冬',32,'男','青海','本科')" 'VALUES连接要插入的字段和字段值，同样字段名称不需要引号。
    'SQLstr = "UPDATE [DB$] SET 备注 = '本科' WHERE 备注 = '大学'"
    myCN.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & FilePath & "; Extended Properties='Excel 12.0; HDR=YES; IMEX=3'" 'HDR 是否有标题；IMEX，013，写读读写
    Set myRS = myCN.Execute(SQLstr)
    With Sheet2
        .Cells.Clear
        For i = 0 To myRS.Fields.Count - 1    '填写标题
            .Cells(1, i + 1) = myRS.Fields(i).Name
        Next i
        .Range("A2").CopyFromRecordset myRS'拷贝数据
        '.Cells.EntireColumn.AutoFit  '自动调整列宽
    End With
    myCN.Close
    '---------------------------------------------------------
    Set myCN = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Function

grab that data by the header with ado api and sql.