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

我需要一个代码来根据匹配的标题将一系列单元格（

H21:H38

）从源工作表（

Acct Total

）复制到目标工作表（

COS%Tracking

）上的相应列。但我遇到的问题是，标题在我的源工作表的单元格A6中（

Acct Total

）。我对它进行了一些研究，发现这段代码适用于其他人：

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

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

有人能根据我的需要帮我编辑这个代码吗

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

---

将以下构造作为解决同一问题的不同方法的起点。有描述性的变量，所以你知道发生了什么

编辑：由于目标工作表第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

见下文：

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

---

“基于匹配的标题”实际上并没有解释要复制到哪个列中。。。。此外，请将所有代码缩进4或更多空格。这些工作表是否在同一工作簿中，标题是否基于匹配的日期匹配？这些工作表是否格式化为日期？还有，源范围总是H21:H38吗？你考虑用公式代替吗？@ AdDrRunDrt是的，我需要，但我需要它是傻瓜证明（是的，我知道我用错了“满”）。目标是将此代码添加到现有宏“开始新时期”，以便在按下该按钮的一周开始时，信息将复制到“跟踪”选项卡，并在那里停留一整年。恐怕有人会将A6单元格中的周期周更改为错误的周，并将跟踪选项卡搞糟。是的，我意识到如果在执行宏之前日期不正确，宏也会发生这种情况。但我祈祷这不会发生。谢谢。评论不适用于扩展讨论或调试会话；这段对话已经结束。其他信息应酌情编辑到问题或答案中。