Pull/Copy specific data columns by searching headers (dynamic)

[Slimline]

Hello everyone,

Can anyone please help construct a code that will:

1) Read the specified header names in Workbook1 (Header name can change)
2) Search for them in Workbook2.
3) When matched/found - Copy the entire columns over to Workbook1.

I've attached two sample files:
Workbook1 = 'Data' which contains a very large dataset.
Workbook2 = 'Monitor' which is the target/destination workbook that specifies/lists the header names. Also will need an "EXTRACT" button to pull data.

My original dataset is very large & has many gaps. Hence I'd like to pull the entire col.

I think array needs to be used in order to make the header range dynamic (so I can add extra ones later) - but I'm finding it very difficult to understand & how to even start.

Many thanks,
Slimline

 

[SirJB7]

Hi, Slimline!

Give a look at the uploaded files.
I defined 3 dynamic named ranges in Data workbook and 1 in Monitor workbook for easy referencing. I moved comments and explanations off table headers & columns.

This is the code:

Option Explicit

Sub WithTheButtonItHasOtherCost()
    '
    ' constants
    Const ksWBSrc = "Data.xlsm"
    Const ksWSSrc = "Data"
    Const ksSrc = "SourceTable"
    Const ksSrcH = "SourceHeaderList"
    Const ksSrcD = "SourceDetailTable"
    Const ksWSTgt = "Monitor"
    Const ksTgt = "TargetTable"
    '
    ' declarations
    Dim wbSrc As Workbook, wbTgt As Workbook, wsSrc As Worksheet, wsTgt As Worksheet
    Dim rngSrc As Range, rngSrcH As Range, rngSrcD As Range, rngTgt As Range
    Dim I As Integer, J As Integer, K As Integer
    '
    ' start
    '  objects
    '  source
    Set wbSrc = Workbooks(ksWBSrc)
    With wbSrc
        Set wsSrc = .Worksheets(ksWSSrc)
        With wsSrc
            Set rngSrc = .Range(ksSrc)
            Set rngSrcH = .Range(ksSrcH)
            Set rngSrcD = .Range(ksSrcD)
        End With
    End With
    '  target
    Set wbTgt = ThisWorkbook
    With wbTgt
        Set wsTgt = .Worksheets(ksWSTgt)
        With wsTgt
            Set rngTgt = .Range(ksTgt)
            With rngTgt
                If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
            End With
        End With
    End With
    '
    ' process
    With rngTgt
        For I = 1 To .Columns.Count
            K = rngSrcH.Columns.Count
            For J = 1 To K
                If .Cells(1, I).Value = rngSrcH.Cells(1, J).Value Then Exit For
            Next J
            ' if found, copy column
            If J <= K Then rngSrcD.Columns(J).Copy rngTgt.Cells(2, I)
        Next I
    End With
    '
    ' end
    '  objects
    Set rngTgt = Nothing
    Set wsTgt = Nothing
    Set wbTgt = Nothing
    Set rngSrcD = Nothing
    Set rngSrcH = Nothing
    Set rngSrc = Nothing
    Set wsSrc = Nothing
    Set wbSrc = Nothing
    '  beep
    MarcLBeepDemo
    '
End Sub

Regards!

 

[Slimline]

Hi SirJB7,

Thanks very much for your response.

I'm reviewing the code and a have a few ques:
1) Is defining constants optional? Would the macro still work without it (provided I replace the constants with the full words/text)?
2) Why are all the end objects set to "nothing"?

Can you please add more notes so I can understand/learn exactly what code is doing at each line or stage.

Slimline

 

[Slimline]

3) How can I expand the header range (in the 'Monitor' wbook) to include more columns to extract? I can't see where & what the actual header range is defined as.

4) Did you use For Next Loop & Loop counter to create this? Or is array used?

Thanks

 

[Slimline]

5) What is the lone below doing in target section:
If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents

 

[SirJB7]

Hi, Slimline!

1) yes, it's optional, just make sure you replace it by the exact definition
2) to free resources (memory) used at allocation time
3) if you remove all the notes/indications (I only moved them) it works for any number of columns... check the defined named ranges in Formula tab, Name Manager
4) 2 nested For...Next loop
5) clears the output range if no. of rows is > 1 (header)

Regards!

 

[Slimline]

Hi SirJB7

Q)May I ask you why in your code: J <=K?

If J <= K Then rngSrcD.Columns(J).Copy rngTgt.Cells(2, I)
Next I

Below is just a section of my code. I've been using your code as guidance to write my own. I'm stuck on an sentence in the For Next Loop (highlighted in red).
My variables are all working correctly.

Problem: How can I get loop to check & match the headers is 2 different workbooks?
Macro just pulls the first 4 columns only & doesn't match the headers i.e. ID in Data wkbook to ID in wkbook.

Source = "Data" workbook
Destination = "Monitor" workbook

Dim iSource As Integer
Dim jDest As Integer
Dim rangecount As Range
Dim numrows As Integer
Dim sHeader As Range
Dim dHeader As Range

Dim DestWS as worksheet
set destWS = Workbooks("Data").worksheets(1)
Dim SourceWS as worksheet
set destWS = Workbooks("Monitor").worksheets(1)

Set dHeader = DestWS.Range("a4", Range("a4").End(xlToRight)) 'Destination header range
Set sHeader = SourceWS.Range("a1", Range("a1").End(xlToRight)) 'Source header range
Set sWS = SourceWB.Worksheets(1)

Set rangecount = sWS.Range("a1", Range("a1").End(xlToRight).End(xlDown))
numrows = Application.CountA(rangecount)

For iSource = 1 To sHeader.Count
For jDest = 1 To dHeader.Count
If Cells(1, iSource) = Cells(1, jDest).Value Then '<--- Issue area
Range(Cells(1, iSource), Cells(1 + numrows, iSource)).Copy Destination:=destWS.Cells(5, jDest)
End If
Next jDest
Next iSource

Thanks
Slimline

 

[SirJB7]

Hi, Slimline!

A) J is the index used to search for an exact column match, K is the max column, J<=K means column found.

Problem: consider uploading a sample file.

Regards!

 

[Slimline]

Hello,

Files uploaded.

When you run the macro you'll see the number of cols pasted is dynamic & works.

However the actual cols pasted are not correct & don't match the ones I want to extract.

I purposely tweaked the macro so when it pastes the cols header names as well. This way you can compare with the header names I want to extract cols for & easily see the mis-match.

The cols from the Data workbook are simply being pasted in their current order.

Thanks!

 

[XLPadawan]

Another option: in A4 of Monitor tab put:

=INDIRECT("[Data.xlsm]Data!"&ADDRESS(ROW(XFA2),(MATCH(A$3,[Data.xlsm]Data!$1:$1,0))))

Copy across and down as far as needed. Notice the MATCH formula is applied to the entire row, making it possible for you to add as many new columns as you wish to the Data tab of Data.xlsm and the formula will not need to be changed.

 

[Slimline]

Hi XLPadawan
Thanks for your response.
My original dataset has over 30,000 rows and 100 columns & I think formulas will really slow it down?

 

[SirJB7]

Hi, Slimline!
Your uploaded files have a quite different version of my uploaded code, which I think it works fine. More indeed your code doesn't work, it displays a subscript out of range at line:

Set DestWB = Workbooks(DestWBname)

where variable DestWBname has the value "Central".
Please get back to the original code or post a fully working modified version.
Regards!

 

[Slimline]

Hi SirJB7

Just wanted to confirm if you updated cell B1 (Source filepath) in the Monitor wkbook? I just ran the code again & the Locals window is showing DestWB is picking up the name "Monitorv3.0.xlsm".

Please see screen shots below.

I noticed "Central" appears if you are not active/haven't selected the Monior wkbook. Please try to ensure Data wkbook is closed & you have clicked on to Monitor sheet.

Let me know how it goes.

 

[Slimline]

 

[Slimline]

 

[SirJB7]

HI, Slimline!

No, I didn't check any value first. Now it runs without crashing but still wrongly.

The problem seems to be in this line:

        If Cells(1, iSource) = Cells(1, jDest).Value Then

You're comparing cells from same implicit object (i.e., not qualified by range or worksheet) so it assumes Activesheet, hence you'll get iSource=jDest for 1 and 1, 2 and 2, and so on, and that's why you're getting col1, col2, col3, in all cases.

Change it to:

        If Cells(1, iSource) = dWS.Cells(1, jDest).Value Then

Regards!

 

[Slimline]

I've made the change as you suggested but now nothing is copied. Very strange.

Please find the files attached.

Thanks

 

[SirJB7]

Hi, Slimline!
You're looking at row 1 of dWS worksheet and your data is at row 5.
Regards!

 

[Slimline]

SirJB7,
Omg! Thank you so much. It finally works! All this time I've had dWS set to row1. Thanks for pointing that out. )

This was a very good learning exercise. Also really appreciate your prompt responses.

 

[SirJB7]

Hi, Slimline!
Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
And a general advice any time you have issues with code (even more if you modify a provided code that was working), debug it line by line with F8 from the first to the last line, checking the values of related variables or objects.
Regards