VBA Copy & Paste to rows based on Column Header

[clazzic]

Hi All,

i found this code and it does 3/4 things i wanted
i.e.
* to copy/paste special values to rows based on column headers from 1 sheet to another
* works regardless of the column order
* pastes the data to the next empty row in the "Target Sheet" (for new data input)

However the requirement for this code is that the # of Column headers in "Target Sheet" must equal to & Match with the Column headers in "Source Sheet".

My dilemma is that the # of column headers in my "Target Sheet's" will vary but the ones it has will match with the ones in "Source Sheet". How do i adjust this code so that it does not require exact number of column headers on both sheets for it to run.

thanks guys,

Sub CopyDataBlocks()


'VARIABLE NAME                 'DEFINITION
Dim SourceSheet As Worksheet    'The data to be copied is here
Dim TargetSheet As Worksheet    'The data will be copied here
Dim ColHeaders As Range         'Column headers on Target sheet
Dim MyDataHeaders As Range      'Column headers on Source sheet
Dim DataBlock As Range          'A single column of data
Dim c As Range                  'a single cell
Dim Rng As Range                'The data will be copied here (="Place holder" for the first data cell)
Dim i As Integer




'Change the names to match your sheetnames:
Set SourceSheet = Sheets("ws1")
Set TargetSheet = Sheets("ws2")




With TargetSheet
    Set ColHeaders = .Range("A5:E5") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:C1")
    Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With


With SourceSheet
    Set MyDataHeaders = .Range("A1:E1")
    
'Makes sure all the column names are the same:
'Each header in Source sheet must have a match on Target sheet (but not necessarily in the same order + there can be more columns in Target sheet)
    For Each c In MyDataHeaders
        If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
            MsgBox "Can't find a matching header name for " & c.Value & vbNewLine & "Make sure the column names are the same and try again."
            Exit Sub    'The code exits here if thereäs no match for the column header
        End If
    Next c
    
'There was a match for each colum name.
'Set the first datablock to be copied:
    Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A




'Resizes the target Rng to match the size of the datablock:
    Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)




'Copies the data one column at a time:
    For Each c In MyDataHeaders
        i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0) 'Finds the matching column name
        Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value    'Writes the values
    Next c




'Uncomment the following line if you want the macro to delete the copied values:
'    Intersect(MyDataHeaders.EntireColumn, DataBlock.EntireRow).ClearContents




End With


End Sub

 

[baitmaster]

does this do it? Change

Set ColHeaders = .Range("A5:E5")

to

Set ColHeaders = .Rows(5)

 

[clazzic]

Hi baitmaster

Thank you for the assistance.
I changed as per the suggestion, but its still triggering the error where it can't find the column header.
Maybe its something to do with my Source range? maybe.

 Set MyDataHeaders = .Range("A1:g1")

 

[tonyyy]

However the requirement for this code is that the # of Column headers in  "Target Sheet" must equal to & Match with the Column headers in  "Source Sheet".

My dilemma is that the # of column headers in my "Target Sheet's" will  vary but the ones it has will match with the ones in "Source Sheet". How  do i adjust this code so that it does not require exact number of  column headers on both sheets for it to run.

I don't think the code requires the number of columns to match; only that the header values match.

still triggering the error where it can't find the column header.

I assume you mean a message box pops up - not that there's an actual vba error - in which case the code is working as designed.

That being said, I think @baitmaster's suggestion is valid - to accommodate all columns in the Target Sheet.

I suspect there may be spaces in either the Target or Source headers which is causing the mismatch, so a TRIM function might be appropriate.

Cheers,

tonyyy

 

[clazzic]

tonyy you're right, it is the pop up message, so the code is working only that it cannot find the header is the target sheet.

im testing this via a generic "Target sheet" = ws2, and "Source Sheet" = ws1

Where ws1 headers from A1-K1 = a, b, c, d, e, f, g, h, i, j, k

Where ws2 headers from A1-E1 = b, c, d, e, a

The pop up message occurs here where theres more headers in the source than the target,
but if i have the same amount of headers in the ws2, the code works wonderfully,
but if i have anything less than the headers in ws1, the pop up will occur,

my dilemma is how to overcome this scenario.

thank you for your help guys.

 

[baitmaster]

So are you looping through the headers in the source worksheet (where there are 11 items), and looking for each one in the destination worksheet (where there are 5 items)? So you have 6 items that won't exist, and hence you're getting an error?

Loop through the smaller [destination] list instead

 

[clazzic]

apologies but i'm abit of a newbie when it comes to macros. =D

whats the code to loop it? sorry to be a pain

 

[baitmaster]

    For Each c In MyDataHeaders
        If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
            MsgBox "Can't find a matching header name for " & c.Value & vbNewLine & "Make sure the column names are the same and try again."
            Exit Sub    'The code exits here if thereäs no match for the column header
        End If
    Next c

This code is a For/Next loop. It looks in turn at each cell c in the range "MyDataHeaders", which you have defined as being the header titles on the source data worksheet. It then looks for each of these in the header titles on the target worksheet, to check that they all exist. The problem is that you now want to extend your source header range to say 11 cells, but 6 of these won't be found and so your code will exit

So you probably need to turn this around and look to the target instead. Do you actually want to just import data from the Source for each value in the Target headers that has a corresponding value in the Source? If so then the following code may help, note that it's untested

Sub copyDataBlocks2()
Dim intErrCount As Integer

' create worksheet objects
Dim shtSource As Worksheet: Set shtSource = Sheets("ws1")
Dim shtTarget As Worksheet: Set shtTarget = Sheets("ws2")

' create range objects
Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:E1")

With shtTarget
    Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A5:E5") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:C1")
    Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With

Dim rngDataColumn As Range

' process data
Dim cl As Range, i As Integer
For Each cl In rngTargetHeaders ' loop through each cell in target header row
    
    ' identify source location
    i = 0 ' reset I
    On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
        i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
    On Error GoTo 0 ' switch error handling back off
    
    ' report if source location not found
    If i = 0 Then
        intErrCount = intErrCount + 1
        Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
        GoTo nextCL
    End If
    
    ' create source data range object
    With rngSourceHeaders.Cells(1, i)
        Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
    End With
    
    ' pass to target range object
    cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value
    
nextCL:
Next cl

' confirm process completion and issue any warnings
If intErrCount = 0 Then
    MsgBox "process completed", vbInformation
Else
    MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
End If
End Sub

 

[clazzic]

Thank you soo much BaitMaster, this really does what i need it to do.

One last question, how would i make it so that i set the Targetsheet as Active sheet and set the range to be the a specific row e.g. Row5 to include all active cells as the Header range?

 

[baitmaster]

We have created a worksheet object for this purpose, so simply amend it to

Dim shtTarget As Worksheet: Set shtTarget = activesheet

Technically we don't need to create this object. We could do away with this line and replace every instance of shtTarget with Activesheet.

The original line is actually bad code too:

Dim shtTarget As Worksheet: Set shtTarget = Sheets("ws2")

We've created a VBA worksheet object named shtTarget. We've then assigned it to the worksheet named in Excel as "ws2". But there is already a VBA object assigned to this worksheet, which you've probably seen before but not realised. The problem with using the Excel sheet name is that anyone can change it and your code fails, however take a look at the VBA Project Explorer. You'll see 2 names for this worksheet, the VBA code name (e.g. Sheet1) and the Excel name in brackets ("ws2"). So rather than create a shtTarget object, we could have just used the VBA code name Sheet1, or better still for clarity changed the VBA code name (using the properties tab) to shtTarget and used that - again doing away with the code above

Now that we have our well-defined worksheet object, we can choose any location we want on it. We can simply use

shtTarget.rows(5)

. Or we can look only at that part of the row that is within the used range of the worksheet

Dim rngHeaders as range
with shtTarget
    set rngHeaders = intersect(.rows(5), .usedrange)
end with

or we can use a named range (much more versatile, and code doesn't fall over when the range moves)
or we can use the Ctrl + F feature to find specific terms... (also versatile)