VBA copy/paste data based off of column headers

[ninjazor]

Hi everybody

Long story short, I work for a construction company and I am in the process of making things much more efficient.
I have built a small database in Access and have a connection pulling all that data into my workbook.
Currently my database has 70 columns and will be expanded to around 200 when its done. With easily 2000 rows when done aswell.
I have built a basic selector with some parameters to pick something out of the database.
I have then got that selection pulling all the info for that particular item from the database using xlookup.

Now I want to create a macro that grabs(copy) info from this and pastes it to 1 of 4 sheets dependant on the data. I would like to be able to have it copy and paste the data to corresponding column headers. For example width to width. drawer box size to drawer box size. Obviously I have to point it to the correct sheet but I can't find any code that simplifies just copying data from one column to its matching column on another page.

Any help would be great. Hope I explained this well enough as I am not a VBA expert.
Here's some pics to hopefully make things easier to understand.


https://imgur.com/a/qBCyUwz
https://imgur.com/a/LoLu4bV

 

[DanteAmor]

Hi @ninjazor, welcome to the forum!


I don't see the examples in your images match.
Then you could explain with other images, the following:
- First, what is the name of the "main" sheet?
- names of the other 4 sheets
- How do I identify which record goes on which destination sheet.
- Which column matches which column. (your two examples you put I don't see on the sheet)


Then your explanation should be consistent with the records in the images.
Try to put more than one record in your examples.

 

[ninjazor]

Sorry for such a late reply. Holidays and long weekend.

Ill try and explain as best I can.

The first image with the green header columns is the go between for the database. Sheet is labelled as "Math"
The second with the grey headers is the destination sheet. Sheet is labelled as "Cut List - Boxes"
There are 3 other sheets but I feel like I want to get 1 to work first then can transfer the code to the others.

So the "Math" sheet has all the info for 1 specific cabinet/box. The one listed there is a B24.
The "Cut List" sheet is only the specific information I need for that specific box and that specific sheet. Essentially all the info from the "Math" sheet would be parsed into the 4 different sheets, dependant on which that info belongs on. For example "Cut List" has all the info for all the pieces needed to make the shell of the cabinet. There is no need to include the the parameters for the door sizes on that sheet. That info would go on the "Doors&Drawers" sheet. This is split apart because when I print stuff off, the pages would go to different people depends on what they do.

So I want to copy the info from the one sheet to the other. FINAL - WIDTH on the "Math" sheet to FINAL - WIDTH to "Cut List - Boxes" Sheet. Using the column headers to match, that way no matter how I change things going forward into the future it doesn't break anything. I can easily make a macro that just copys cells to cells but that has a ton of area for mistakes, which is what I am trying to avoid.

I hope that made sense. I did find some code that may be on the right track but it currently doesn't work. I will post it just in case.

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

 

[DanteAmor]

I hope that made sense. I did find some code that may be on the right track but it currently doesn't work. I will post it just in case.

It makes no sense to me.


You didn't explain any example as I suggested in post #2 .


I don't know what to copy or where to paste it.

 

[ninjazor]

Heres some full screen images. Take notice of the column header names. They are the same between sheets.
This image is the database sheet.
https://imgur.com/a/VMM6XfC

This image is the sheet I am trying to automate the copying too
https://imgur.com/a/yBCu3rC

 

[ninjazor]

Do my screenshots make things clearer?

 

[MoshiM]

Do my screenshots make things clearer?

I haven't looked at your examples, but you could store the headers in an array and then pass each element of that array into a range.find or a match function on the headers to find the correct column.

[COLOR=#ff0000]'These_On is an array of Check Box names correlating to possible column headers in row 1 while row 2 is the value of the check box.

'Temp is an array of headers from a sheet

'2nd row of the array Column_Info contains cell addresses

'[/COLOR][COLOR=#0000ff]You will need error handling for if the header doesn't exist {not shown} if you model what you want to do after this.[/COLOR]
 
    For Y = 0 To UBound(These_ROn, 1) 'loop through check box values and captions
            
            If These_ROn(Y, 1) = True Then 'if checkbox is on
                    
                 Column_Found = WorksheetFunction.Match(These_ROn(Y, 2), Temp, 0) 'match the check box caption with a header
                     
                  ERF = ERF & "," & Column_Info(2, Column_Found)'store cell address in string for later use

             End If 
                
Next_Column_Loop:


   Next Y

 

[DanteAmor]

Try this

Sub copy_paste_data_based_column_headers()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long
  Set sh1 = Sheets("Database")          'origin
  Set sh2 = Sheets("Cut List - Boxes")  'destination
  sh2.Rows("2:" & Rows.Count).ClearContents
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
  'Store headers in the "a" variable of the origin sheet
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)
  'Store headers in the "b" variable of the destination sheet
  lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
  b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(b, 1)
      If b(j, 1) = a(i, 1) Then
        sh2.Cells(2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
        Exit For
      End If
    Next
  Next
  MsgBox "End"
End Sub

 

[ninjazor]

Try this

Sub copy_paste_data_based_column_headers()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long
  Set sh1 = Sheets("Database")          'origin
  Set sh2 = Sheets("Cut List - Boxes")  'destination
  sh2.Rows("2:" & Rows.Count).ClearContents
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
  'Store headers in the "a" variable of the origin sheet
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)
  'Store headers in the "b" variable of the destination sheet
  lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
  b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(b, 1)
      If b(j, 1) = a(i, 1) Then
        sh2.Cells(2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
        Exit For
      End If
    Next
  Next
  MsgBox "End"
End Sub

This works great. Thank you.
3 more questions tho.
1. Can I get it to check if the row already has data in it and if so to then go down a row? So if I want to run this 10 times, I would then have 10 rows of data on the cut sheet.
2. If I change the name of the destination sheet to one of my other ones, can I just essentially just copy this and have it run again and do the same thing with a different set of column headers?
3. I am a novice at best at VBA, can I add some spaces to this code to make it easier for me to read?

Thanks again.

 

[DanteAmor]

1. Can I get it to check if the row already has data in it and if so to then go down a row? So if I want to run this 10 times, I would then have 10 rows of data on the cut sheet. Ready, I added an instruction to copy down the last row with data.
2. If I change the name of the destination sheet to one of my other ones, can I just essentially just copy this and have it run again and do the same thing with a different set of column headers? Only change the name of the destination sheet
3. I am a novice at best at VBA, can I add some spaces to this code to make it easier for me to read? YES

Try this

Sub copy_paste_data_based_column_headers()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long, lr2 As Long
  
  Set sh1 = Sheets("Database")          'origin
  Set sh2 = Sheets("[COLOR=#ff0000]Cut List - Boxes")  'destination[/COLOR]
  
[COLOR=#008000]  'last row on origin sheet[/COLOR]
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
[COLOR=#008000]  'last row on destination sheet[/COLOR]
[COLOR=#0000ff]  lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1[/COLOR]
  
[COLOR=#008000]  'Store headers in the "a" variable of the origin sheet[/COLOR]
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)
  
[COLOR=#008000]  'Store headers in the "b" variable of the destination sheet[/COLOR]
  lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
  b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(b, 1)
[COLOR=#008000]    [/COLOR]
[COLOR=#008000]      'Compare header[/COLOR]
      If b(j, 1) = a(i, 1) Then
[COLOR=#008000]        'copy the column[/COLOR]
        sh2.Cells([COLOR=#0000ff]lr2[/COLOR], j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value
        Exit For
      End If
      
    Next
  Next
  MsgBox "End"
End Sub