如何根据标题复制一系列单元格以粘贴到另一个工作表并匹配标题？

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 ie 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