Copy column based on header value then paste in different workbook with corresponding header


New Member
Sep 26, 2015
I am having an issue with getting this to work. I have tried multiple functions that do various things, match seems to be the best option. I do apologize for my code as it is very sloppy while I work, I tend to go back and clean it up once it is all working.
I have noted in the code what it does or is supposed to do. I am working with 2 workbooks, workbook(productivity) will have all the variables, the second workbook will have different variables based on the data that is pulled from our system. Any help will be greatly appreciated!

Sub productivitycopy()

Dim strCoach As String
Dim strRep As String

'these variables represent the headers that may POSSIBLY be in the workbook, but are always present in the 'second workbook
Dim strBRVMT As String
Dim strBRVT As String
Dim strEMER As String
Dim strFMLA As String
Dim strHOL As String
Dim strHRAPP As String
Dim strHRBRK As String
Dim strJURY As String
Dim strLOA As String
Dim strMATO As String
Dim strOOH As String
Dim strOUTAGE As String
Dim strPLHR As String
Dim strPLOA As String
Dim strPREAB As String
Dim strPRETO As String
Dim strPSUSP As String
Dim strSEASONAL As String
Dim strSCHR As String
Dim strSPECLA As String
Dim strSTFMLA As String
Dim strTERM As String
Dim strTRAN As String
Dim strUSPS As String
Dim strWKCM As String
Dim strWTHR As String
Dim rng2 As Range
Dim RowNum As Integer, colNum As Integer
Dim wkProd As Workbook, wk As Workbook, wk1 As Workbook
Dim shShrink As Worksheet, shShrink2 As Worksheet

strPath = "S:\National RP\RTM Tools & Reports\Current TEMPLATES\Productivity.xlsx"
Set wkProd = Workbooks("Productivity")
Set shShrink = wkProd.Worksheets("Shrinkage")
Set shShrink2 = Worksheets("Shrinkage default")

'this section only works if all of the match selections are present in the workbook
strBRVMT = Application.WorksheetFunction.Match("BRVMT", Range("A1:AD1"), 0)
strBRVT = Application.WorksheetFunction.Match("BRVT", Range("A1:AD1"), 0)
strEMER = Application.WorksheetFunction.Match("EMER", Range("A1:AD1"), 0)
strFMLA = Application.WorksheetFunction.Match("FMLA", Range("A1:AD1"), 0)
strHOL = Application.WorksheetFunction.Match("HOL", Range("A1:AD1"), 0)
strHRAPP = Application.WorksheetFunction.Match("HRAPP", Range("A1:AD1"), 0)
strHRBRK = Application.WorksheetFunction.Match("HRBRK", Range("A1:AD1"), 0)
strJURY = Application.WorksheetFunction.Match("JURY", Range("A1:AD1"), 0)
strLOA = Application.WorksheetFunction.Match("LOA", Range("A1:AD1"), 0)
strMATO = Application.WorksheetFunction.Match("MATO", Range("A1:AD1"), 0)
strOOH = Application.WorksheetFunction.Match("OOH", Range("A1:AD1"), 0)
strOUTAGE = Application.WorksheetFunction.Match("OUTAGE", Range("A1:AD1"), 0)
strPLHR = Application.WorksheetFunction.Match("PLHR", Range("A1:AD1"), 0)
strPLOA = Application.WorksheetFunction.Match("PLOA", Range("A1:AD1"), 0)
strPREAB = Application.WorksheetFunction.Match("PREAB", Range("A1:AD1"), 0)
strPRETO = Application.WorksheetFunction.Match("PRETO", Range("A1:AD1"), 0)
strPSUSP = Application.WorksheetFunction.Match("PSUSP", Range("A1:AD1"), 0)
strSEASONAL = Application.WorksheetFunction.Match("SEASONAL", Range("A1:AD1"), 0)
strSCHR = Application.WorksheetFunction.Match("SCHR", Range("A1:AD1"), 0)
strSPECLA = Application.WorksheetFunction.Match("SPECLA", Range("A1:AD1"), 0)
strSTFMLA = Application.WorksheetFunction.Match("STFMLA", Range("A1:AD1"), 0)
strTERM = Application.WorksheetFunction.Match("TERM", Range("A1:AD1"), 0)
strTRAN = Application.WorksheetFunction.Match("TRAN", Range("A1:AD1"), 0)
strUSPS = Application.WorksheetFunction.Match("USPS", Range("A1:AD1"), 0)
strWKCM = Application.WorksheetFunction.Match("WKCM", Range("A1:AD1"), 0)
strWTHR = Application.WorksheetFunction.Match("WTHR", Range("A1:AD1"), 0)

'this part works perfectly, these values will always be true and the column headers will always be the same
RowNum = WorksheetFunction.CountA(Range("A:A")) - 1
rngCoach = Range("A2:B" & RowNum).Copy
shShrink.Range("A13").PasteSpecial xlPasteAll

'this code worked fine, I had strHRAPP = "HRAPP", so the code found HRAPP in the headers.
'the problem is I do not know how to put this in a loop as I would need to do this for the entire list of headers
'colNum = Application.WorksheetFunction.Match(strHRAPP, Range("A1:AD1"), 0)

'this partially works, I know I need a loop as it will stop when the if value becomes true and completes its 'request.
If strBRVMT = 3 Then
    Range("c2:c" & RowNum).Copy
    shShrink.Range("C13").PasteSpecial xlPasteAll
    ElseIf strBRVT = 3 Or strBRVT = 4 Then
        Range("c2:C" & RowNum).Copy
        shShrink.Range("d13").PasteSpecial xlPasteAll
End If

End Sub

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back