Marco to search for column header in Workbook and copy data

EdwardSurrey

New Member
Joined
May 13, 2015
Messages
36
Office Version
  1. 365
Platform
  1. Windows
Hello

Please can I have help creating a macro for copying data from one workbook to another? It needs to search for the column headers and copy the data below it, ignoring the column headers it can't find.

Specifically the following:-

1) The user is in Sheet1 in Workbook A and wants to copy data from Sheet1 in Workbook B.
2) The user can browser for the source file (Workbook B).
3) The first sheet on the source file has data in 20 columns with Headings always in ROW 1. However, the headings are not always in the same column within different source files.
4) The Marco needs to Find column heading and then copy all the data in the column below the heading. (could vary from from 1 to 10,000 rows).
5) If the heading is not there it will just ignore and move onto the next heading to search for.
6) For each heading it finds, it should COPY the data (as values) into the respective column in the Sheet 1 of Workbook A. Let's say there are 5 headings it needs to find (Serial Number, Product Name, Country, IP Address, Site Name).
7) It should then close the source file (Workbook B).

Thanks for reading and/or helping :)

Ed
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Place this macro in Workbook A
VBA Code:
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial Number", "Product Name", "Country", "IP Address", "Site Name")
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd1 Is Nothing Then
            fnd1.Offset(1).Resize(lRow - 1).Copy desWS.Cells(desWS.Rows.Count, fnd2.Column).End(xlUp).Offset(1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Place this macro in Workbook A
VBA Code:
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial Number", "Product Name", "Country", "IP Address", "Site Name")
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd1 Is Nothing Then
            fnd1.Offset(1).Resize(lRow - 1).Copy desWS.Cells(desWS.Rows.Count, fnd2.Column).End(xlUp).Offset(1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub


Thank you your really quick reply!

it seems to partially work, but there's a few issues.

1) but it's missing columns (such as Serial)
2) it seems to error when it can't find a column heading
3) Sorry I should have also said, it needs to replace any data (from row 1 to 10,000) that has already been imported. Not add to it. This is intended to be used every month.
4) it also needs to close Workbook B at the end.

I put the dummy Workbook A and B on WeTransfer here: A.xlsx and 1 more file
 
Upvote 0
Try:
VBA Code:
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range, lRow As Long, lRow2 As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial", "Product Name", "Country", "IP Address", "Site Name")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow1 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd2 Is Nothing Then
            fnd2.Offset(1).Resize(lRow2 - 1).ClearContents
            Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd1 Is Nothing Then
                fnd1.Offset(1).Resize(lRow1 - 1).Copy desWS.Cells(2, fnd2.Column).End(xlUp).Offset(1)
            End If
        End If
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Try:
VBA Code:
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range, lRow As Long, lRow2 As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial", "Product Name", "Country", "IP Address", "Site Name")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow1 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd2 Is Nothing Then
            fnd2.Offset(1).Resize(lRow2 - 1).ClearContents
            Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd1 Is Nothing Then
                fnd1.Offset(1).Resize(lRow1 - 1).Copy desWS.Cells(2, fnd2.Column).End(xlUp).Offset(1)
            End If
        End If
    Next i
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

This works! Thank you :)

One thing - is it possible at the end of the macro to place the filename of the source data into a cell somewhere?
 
Upvote 0
You are very welcome. :) Change the range (in red) to suit your needs.
Rich (BB code):
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range, lRow As Long, lRow2 As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial", "Product Name", "Country", "IP Address", "Site Name")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow1 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd2 Is Nothing Then
            fnd2.Offset(1).Resize(lRow2 - 1).ClearContents
            Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd1 Is Nothing Then
                fnd1.Offset(1).Resize(lRow1 - 1).Copy desWS.Cells(2, fnd2.Column).End(xlUp).Offset(1)
            End If
        End If
    Next i
    desWS.Range("A1") = ActiveWorkbook.Name
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You are very welcome. :) Change the range (in red) to suit your needs.
Rich (BB code):
Sub openFile()
    Application.ScreenUpdating = False
    Dim myFile As String, colArr As Variant, desWS As Worksheet, i As Long, fnd1 As Range, fnd2 As Range, lRow As Long, lRow2 As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial", "Product Name", "Country", "IP Address", "Site Name")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    myFile = Application.GetOpenFilename
    Workbooks.Open Filename:=myFile
    lRow1 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = LBound(colArr) To UBound(colArr)
        Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd2 Is Nothing Then
            fnd2.Offset(1).Resize(lRow2 - 1).ClearContents
            Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd1 Is Nothing Then
                fnd1.Offset(1).Resize(lRow1 - 1).Copy desWS.Cells(2, fnd2.Column).End(xlUp).Offset(1)
            End If
        End If
    Next i
    desWS.Range("A1") = ActiveWorkbook.Name
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Works perfectly. Much appreciated :)
 
Upvote 0
Hi Mumps,

I am trying to achieve exactly what Ed was trying with a couple of changes:

1. I have 12 workbooks "Workbook 1", "Workbook 2"..."Workbook 12" that are placed in one folder. Thus I would then need to modify the file directory to point to a folder say "C>User>NewBie>DataDump" and then pick all the files that are present rather than a single one like Ed.

2. I would then append all the "Product names" from WB1-12 one below the other in my master workbook under the relevant column header.

Also, I tried running the code you wrote above to make edits on my own but it gives me an "Error 1004 Application-defined or Object-defined error” for some reason and hence I am lost on how to proceed.

Any help will be very much appreciated
 
Upvote 0
(Untested) Change the header names (in red) and the sheet names (in blue) to suit you needs.
Rich (BB code):
Sub CopyData()
    Application.ScreenUpdating = False
    Dim colArr As Variant, desWS As Worksheet, wkbSource As Workbook, i As Long, fnd1 As Range, fnd2 As Range, lRow As Long, lRow2 As Long
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    colArr = Array("Serial", "Product Name", "Country", "IP Address", "Site Name")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Const strPath As String = "C:\User\NewBie\DataDump\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        lRow1 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = LBound(colArr) To UBound(colArr)
            Set fnd2 = desWS.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd2 Is Nothing Then
                Set fnd1 = Sheets("Sheet1").Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd1 Is Nothing Then
                    fnd1.Offset(1).Resize(lRow1 - 1).Copy desWS.Cells(desWS.Rows.Count, fnd2.Column).End(xlUp).Offset(1)
                End If
            End If
        Next i
        wkbSource.Close False
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,325
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top