Copy columns from one workbook to another - excel

Question

I want to fill in the workbook that holds the macro with data from another workbook. The data I need to copy can be on different columns on the source file, depending on the way this source file is generated. So I may run into a problem, because I might get the data I want on a wrong column, or I may even get data I do not want. So I guess it's better to look for the column header (which are always the same string, no matter how the report is generated). I can use the Find method to search for the headers, but how to copy the rows below each header? The range where I want the data pasted are always the same ranges on the paste workbook, and always the first sheet.
Following is my current code:
Sub Import()
' Looks up for the Source Report file and imports its data into wkbk that holds the macro
On Error Resume Next
' Defines Source Report file variable
Dim SourceFile As Variant
' Opens the SourceFile
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
End If
SourceFileDir = Dir(SourceFile)
' Looks up the last row on SourceFile to copy the entire data later
With Workbooks(SourceFileDir).Worksheets(1)
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' MsgBox ("The last row of data in the Source File is " & LastRow)
' Sets echo off before copying
Application.ScreenUpdating = False
' Copies SourceFile data into paste file, the one that holds the macro
' Serial Number
Workbooks(SourceFileDir).Worksheets(1).Range("E7:E" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("A38").PasteSpecial xlPasteValues
' Product ID
Workbooks(SourceFileDir).Worksheets(1).Range("A7:A" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("B38").PasteSpecial xlPasteValues
' Gets out of copy mode
Application.CutCopyMode = False
' Sets echo back on
Application.ScreenUpdating = True
End Sub
The total number of columns I need is 9, the code above just shows two of them, Serial Number and Product ID.
Thanks for your help.

Answer 1

Workbook to Workbook
Adjust the values in the constants section and right below in the Headers array.
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim Headers As Variant
Headers = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(Headers)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=Headers(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=Headers(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub
EDIT:
Since some of the headers have different values (names) on each sheet you should use two arrays (one for each sheet) and adjust the values appropriately:
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim HeadSource As Variant
Dim HeadPaste As Variant
HeadSource = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
HeadPaste = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(HeadSource)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=HeadSource(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=HeadPaste(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub