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

Question

我需要一个代码来根据匹配的标题将源工作表 (Acct Total) 中的一系列单元格 (H21:H38) 复制到目标工作表 (COS% Tracking) 上的相应列。但我遇到的问题是标题位于源工作表 (Acct Total) 上的单元格 A6 中。我研究了一下，发现这段代码对其他人有用：

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

所以我的问题是我不知道从哪里开始编辑此代码以按我的需要工作。此代码通过使用单元格范围上方的标题来工作，但在我的情况下不会这样做。我会附上图片，希望我不会太含糊。

有人可以根据我的需要帮助我编辑此代码吗？

编辑：日期来源的附加图片。 GL Code Tab

Answer 1

请查看以下构造作为解决同一问题的不同方法的起点。有描述性变量，因此您可以了解正在发生的事情。

编辑：由于目标工作表第 3 行被锁定，代码已被修改为使用匹配函数返回找到字符串的列号（如果找到）。

基本上：

设置您的源和目标工作表。

Set sourceWorksheet = wb.Sheets("Acct Total")
Set targetWorksheet = wb.Sheets("COS% Tracking")

定义您的目标值（您尝试匹配的日期）和来源范围

targetDate = Trim$(sourceWorksheet.Range("A6"))
Set sourceRange = sourceWorksheet.Range("H21:H38")

查找目标工作表中值 (targetDate) 所在的列号

colNum = Application.WorksheetFunction.Match(targetDate, searchRange, 0)

添加错误处理以防它不存在，即如果找不到日期（作为字符串）......

ErrHand: 'code in this section.....

设置目标数据的粘贴地址

Set targetRange = .Range(Cells(4, colNum), Cells(21, colNum))

将目标范围设置为等于源范围。

targetRange.Value = sourceRange.Value

酌情调整。

将它们放在一起，您会得到以下内容：

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

请参阅以下内容：

Finding address of text in worksheet

Moving data between sheets