Copy paste columns based on matching header into another workbook

[cstuder]

I have a worksheet where I copy/paste columns into a template (in this case Brad.xlsx columns A, B, L, Z) by using the below macro. It's opening the template document but not copying the columns. Would someone please help me make this work? The columns in the original worksheet aren't always in this order.

Sub CHCopyMatchingColumns()
' CHCopyMatchingColumns Macro
' Copy SPA into pdem template

Dim head_count As Integer
Dim row_count As Integer
Dim Col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet



Set ws = ThisWorkbook.Sheets("Sheet1")

' Count headers in this workbook
head_count = WorksheetFunction.CountA(ws.Range("A1", ws.Range("A1").End(xlToRight)))

' Open other workbook and count rows and columns
Workbooks.Open FileName:="G:\REBATES\CutlerHammer\PDEM load\test\template.xlsx"
Dim wb As Workbook
Set wb = ActiveWorkbook
wb.Sheets(1).Activate

row_count = WorksheetFunction.CountA(activeSheet.Range("A1", activeSheet.Range("A1").End(xlDown)))
Col_count = WorksheetFunction.CountA(activeSheet.Range("A1", activeSheet.Range("A1").End(xlToRight)))

For i = 1 To head_count
j = 1
Do While j <= Col_count
If ws.Cells(1, i).Value = activeSheet.Cells(1, j).Text Then
ws.Range(ws.Cells(1, i), ws.Cells(ws.Cells(ws.Rows.Count, i).End(xlUp).Row, i)).Copy
activeSheet.Cells(1, j).PasteSpecial xlPasteValues
Application.CutCopyMode = False
j = Col_count
End If
j = j + 1
Loop
Next i


End Sub

 

[mumps]

IT is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your two sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[cstuder]

I have a worksheet where I copy/paste columns into a template (in this case Brad.xlsx columns A, B, L, Z) by using the below macro. It's opening the template document but not copying the columns. Would someone please help me make this work? The columns in the original worksheet aren't always in this order.

Sub CHCopyMatchingColumns()
' CHCopyMatchingColumns Macro
' Copy SPA into pdem template

Dim head_count As Integer
Dim row_count As Integer
Dim Col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet



Set ws = ThisWorkbook.Sheets("Sheet1")

' Count headers in this workbook
head_count = WorksheetFunction.CountA(ws.Range("A1", ws.Range("A1").End(xlToRight)))

' Open other workbook and count rows and columns
Workbooks.Open FileName:="G:\REBATES\CutlerHammer\PDEM load\test\template.xlsx"
Dim wb As Workbook
Set wb = ActiveWorkbook
wb.Sheets(1).Activate

row_count = WorksheetFunction.CountA(activeSheet.Range("A1", activeSheet.Range("A1").End(xlDown)))
Col_count = WorksheetFunction.CountA(activeSheet.Range("A1", activeSheet.Range("A1").End(xlToRight)))

For i = 1 To head_count
j = 1
Do While j <= Col_count
If ws.Cells(1, i).Value = activeSheet.Cells(1, j).Text Then
ws.Range(ws.Cells(1, i), ws.Cells(ws.Cells(ws.Rows.Count, i).End(xlUp).Row, i)).Copy
activeSheet.Cells(1, j).PasteSpecial xlPasteValues
Application.CutCopyMode = False
j = Col_count
End If
j = j + 1
Loop
Next i


End Sub

IT is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your two sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Please try this: Cindy Studer sent you 2 items

I'm trying to copy all the "Brad" data in columns A, B, L, Z to the "template" columns W, Q, R, T. The "template" will always be the same but the "brad" worksheet will different (names) and the columns will not always in the same order. There also may be different headings in "brad" that may be copied to the template - ABLZ are just examples. The macro I have isn't copying any data (like it's not finding the headers). I feel like this should be simple, but I'm making it difficult! Any help is appreciated.

 

[Sequoyah]

Hello everyone,
it works fine for me, I simply copied your code into a standard module of the Brad workbook, adapted the path of the Template workbook, the data is copied into columns A, Q, R, T, W, AD of the target workbook

 

[cstuder]

Hello everyone,
it works fine for me, I simply copied your code into a standard module of the Brad workbook, adapted the path of the Template workbook, the data is copied into columns A, Q, R, T, W, AD of the target workbook

When I run the macro, the template is blank (besides the header row). Any suggestions? File format?

 

[mumps]

Place the following macro in a regular module in the Brad workbook.

There also may be different headings in "brad" that may be copied to the template - ABLZ are just example

Since the headers can change, you will have to hard code the headers you want to copy. You can add and/or delete headers in the array in the code (in red) to suit your needs.

Sub CHCopyMatchingColumns()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, lRow As Long, arr As Variant, i As Long, header1 As Range, header2 As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    arr = Array("Product", "Reb Code", "Reb Amount", "Reb Percent")
    Workbooks.Open Filename:="G:\REBATES\CutlerHammer\PDEM load\test\Template.xlsx"
    For i = LBound(arr) To UBound(arr)
        Set header1 = srcWS.Rows(1).Find(arr(i), LookIn:=xlValues, lookat:=xlWhole)
        Set header2 = Sheets("Sheet1").Rows(1).Find(arr(i), LookIn:=xlValues, lookat:=xlWhole)
        If Not header2 Is Nothing Then
            srcWS.Range(srcWS.Cells(2, header1.Column), srcWS.Cells(lRow, header1.Column)).Copy
            Sheets("Sheet1").Cells(2, header2.Column).PasteSpecial xlPasteValues
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub