How can I copy a range of cells based on a Header to paste to another worksheet and match the headers? - vba

Question

I need a code to copy a range of cells (H21:H38) from my source worksheet (Acct Total) to a corresponding column on my target worksheet (COS% Tracking) based on matching headers. But the hiccup I have is that the header is in cell A6 on my source worksheet (Acct Total). I've researched it a bit and I've found this code that worked for someone else:
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
So my issue is that I don't know where to begin to edit this code to work like I need. This code worked by using the header above the range of cells but that won't do in my case. I'll attach pictures so that hopefully I'm not too vague.
Can someone help me to edit this code according to my needs?
Edit: Additional Picture for the source of the dates.
GL Code Tab

Answer 1

Look at the following construct as a starting point for a different way to solve the same problem. There are descriptive variables so you have an idea of what is happening.
Edit: As the target sheet row 3 is locked, code has been amended to use Match function to return column number where string is found (if found).
Essentially:
Set your source and target worksheets.
Set sourceWorksheet = wb.Sheets("Acct Total")
Set targetWorksheet = wb.Sheets("COS% Tracking")
Define your target value (the date you are trying to match on) and source range
targetDate = Trim$(sourceWorksheet.Range("A6"))
Set sourceRange = sourceWorksheet.Range("H21:H38")
Find the column number of where value (targetDate) is present in the target sheet
colNum = Application.WorksheetFunction.Match(targetDate, searchRange, 0)
Add error handling in case it is not present i.e. if date (as string) is not found....
ErrHand: 'code in this section.....
Set the address of where the target data will be pasted
Set targetRange = .Range(Cells(4, colNum), Cells(21, colNum))
Set the target range to be equal to the source range.
targetRange.Value = sourceRange.Value
Adapt as appropriate.
Putting it together you getting something along the lines of the following:
Option Explicit
Public Sub copydata()
Dim sourceRange As Range
Dim targetDate As String
Dim targetRange As Range
Dim wb As Workbook
Dim sourceWorksheet As Worksheet
Dim targetWorksheet As Worksheet
Dim searchRange As Range
Set wb = ThisWorkbook
Set sourceWorksheet = wb.Sheets("Acct Total")
Set targetWorksheet = wb.Sheets("COS% Tracking")
targetDate = Trim$(sourceWorksheet.Range("A6"))
Set sourceRange = sourceWorksheet.Range("H21:H38")
Set searchRange = targetWorksheet.Rows(3)
On Error GoTo ErrHand
Dim colNum As Long
colNum = Application.WorksheetFunction.Match(targetDate, searchRange, 0)
With targetWorksheet
Set targetRange = .Range(Cells(4, colNum), Cells(21, colNum))
targetRange.Value = sourceRange.Value
End With
ErrHand:
If Err = 1004 Then
MsgBox "Not found: " & targetDate
Err.Clear
Exit Sub
End If
End Sub
See the following:
Finding address of text in worksheet
Moving data between sheets