Marco to search for column header in Workbook and copy data

[EdwardSurrey]

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

 

[mumps]

Place this macro in Workbook A

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

 

[EdwardSurrey]

Place this macro in Workbook A

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

 

[mumps]

Try:

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

 

[EdwardSurrey]

Try:

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?

 

[mumps]

You are very welcome. Change the range (in red) to suit your needs.

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

 

[EdwardSurrey]

You are very welcome. Change the range (in red) to suit your needs.

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

 

[mumps]

You are very welcome.

 

[Newbie06]

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

 

[mumps]

(Untested) Change the header names (in red) and the sheet names (in blue) to suit you needs.

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