VBA: How to search for column in one file and copy values to matching column in other file

[JimKnopf]

Hey everybody!

I'm trying to write a macro that copies values from one workbook (which I select when running the macro) to my main workbook (Sheet "Data"). This file has several columns but I only need the values in the column with the header "Name" and "Volume". The data in these two columns should then be copied into the column of the same name in the main workbook ("Data"). The columns "Name" and "Volume" are not always in the same column depending on the file I import data from. How can I do this? As of now my macro copies everything (see below).

Thanks in advance!

Sub ImportData()
Sheets("Data").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents


ChDrive "C:"ChDir "C:"
Filename = Application.GetOpenFilename("Excel files (*.xls*), *.xls*")
Set TargetWorkbook = ActiveWorkbook
Set TargetSheet = ActiveWorkbook.Sheets("Data")
If Filename <> False Then
  Workbooks.Open (Filename)
  
  
  Range("A2").Select
  Set ImportWorkbook = ActiveWorkbook
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    TargetWorkbook.Activate
    TargetSheet.Range("A2").Select
    ActiveSheet.Paste
  ImportWorkbook.Activate
  Application.CutCopyMode = False
  ActiveWorkbook.Close 0
  TargetWorkbook.Activate

 

[Warship]

Try (untested):

Sub ImportData()
    Dim TargetWorkbook As Workbook, ImportWorkbook As Workbook
    Dim TargetSheet As Worksheet, ImportSheet As Worksheet
    Dim LastRow As Long, fnd As Range, arrColRng As Variant, i As Integer
    
    Sheets("Data").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    
    arrColRng = Array("Name", "A2", "Volume", "B2")
    
    Set TargetWorkbook = ThisWorkbook
    Set TargetSheet = TargetWorkbook.Sheets("Data")
    
    Filename = Application.GetOpenFilename("Excel files (*.xls*), *.xls*")
    If Filename <> False Then
        Workbooks.Open (Filename)
        Set ImportWorkbook = ActiveWorkbook
        Set ImportSheet = ImportWorkbook.Sheets("Data")
            
        For i = 1 To 4 Step 2
            Set fnd = ImportSheet.Rows(1).Find(arrColRng(i), , , xlWhole, xlColumns)
            If Not fnd Is Nothing Then
                With ImportSheet
                    LastRow = .Cells(Rows.Count, fnd.Column).End(xlUp).Row
                    .Range(Cells(2, fnd.Column), Cells(LastRow, fnd.Column)).Copy TargetSheet.Range(arrColRng(i + 1))
                End With
            Else
                MsgBox arrColRng(i) & " Column not found"
                Exit Sub
            End If
        Next i
        
        ImportWorkbook.Close 0
    End If
End Sub