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

 

[clazzic]

Perfect, this solves everything. Thank you so much BaitMaster

 

[clazzic]

Oh BaitMaster,

just want to say thank you again,

i just realised that the function where it will copy over data to next empty row in the Target sheet (for scenarios where new data is added into the Source sheet) doesnt seem to work anymore.

it just overrides the data that is already there.

is there a way to do this.

i was thinking that this bit was meant to do just that but it doesnt.

[COLOR=#333333]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[/COLOR]

 

[baitmaster]

Yes that line is supposed to do that but it does have it's weaknesses

You're starting in the very end cell of column A and then jumping up to the first cell found with data in it, and then stepping down a row. The problem is that if column A is not in use, then you won't necessarily find the last row of data. Is column A getting filled each time?

We could change this row to look at column B instead [.Cells(.Rows.Count, 2).__], or introduce a function that finds the actual last used row of the worksheet. The following is a piece of code that I've used more times than I can count:

Function lastUsedRow(ws As Worksheet) As Long
On Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0
End Function

You can call it using e.g.

msgbox lastusedrow(sheets(1))

or

[COLOR=#333333].Cells(.Rows.Count, lastusedrow(ws)).__[/COLOR]

 

[clazzic]

true, column A doesnt always have data,

so basically, i put

Function lastUsedRow(ws As Worksheet) As LongOn Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0
End Function

in one of the modules, and then replace

Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

with

Dim rngPastePoint As Range: Set rngPastePoint = [COLOR=#333333].Cells(.Rows.Count, lastusedrow(ws)).__[/COLOR]

??

 

[baitmaster]

Sorry I wasn't clear, was trying to demonstrate that you can get the result from the function in different ways. Looks like I wrote the example wrong too, so ignore it! In your case you want to find the first empty row of the worksheet, which is the last used row + 1. We still want to use column A, but without being affected if it's empty

Dim rngPastePoint As Range: Set rngPastePoint = .Cells([COLOR=#333333]lastusedrow(ws)+1,1)[/COLOR]

 

[VBA learner ITG]

Dear baitmaster

I was wondering if you could help me.

I hope you dont mind me using your code as it works for me, however i am having the same issue Classic as the copy and paste into next blank row doesn't work on my mac even with the variances in the codes you have posted on this forum thread.

Can i get your guidance at all, please.

I am another VBA newbie.