Excel VBA：如何实现按日期匹配将KPI值写入历史表时间线？

问题背景 #

工作簿包含三个固定名称的工作表：SheetMain、SheetC1（用户数据输入表）和SheetDest（历史日志表）。已实现从SheetC1向SheetDest复制数据的功能，现在需要完成：读取SheetC1!C2的日期值（常规格式），在SheetDest第2行的21-100列中找到匹配日期，将SheetC1!AD27的KPI值写入对应列的第3行。

现有循环代码的问题 #

原循环逻辑存在三个核心问题：

• 提前终止循环：Else分支里的Exit For会导致第一次遇到不匹配的列就直接退出循环，无法遍历所有目标列
• 未指定工作表：Cells(3, i)未明确指定为SheetDest，会默认使用当前激活的工作表，导致写入位置错误
• 日期格式不兼容：SheetC1!C2是常规格式，直接赋值给Date类型变量可能存在转换误差，且SheetDest的日期单元格可能是文本格式，导致日期比较失败

修正后的完整代码 #

Sub Historie_speichern()
    Dim SheetMain As Worksheet, SheetDest As Worksheet, SheetC1 As Worksheet
    Dim i As Long
    Dim DataDate As Variant
    Dim kpiValue As Variant
    
    ' 初始化工作表对象
    Set SheetMain = ThisWorkbook.Sheets("B1 PV Application")
    Set SheetDest = ThisWorkbook.Sheets("C0 EV (Historie)")
    Set SheetC1 = ThisWorkbook.Sheets("C1 EV Application")
    
    ' 已实现的数据复制逻辑（保留原功能）
    SheetC1.Range("C4:F22").Copy
    SheetDest.Range("B2:E20").PasteSpecial xlValues 'Table C0 Part 1
    
    SheetC1.Range("N4:O22").Copy
    SheetDest.Range("F2:G20").PasteSpecial xlValues 'Table C0 Part 2.1
    
    SheetC1.Range("Q4:R22").Copy
    SheetDest.Range("H2:I20").PasteSpecial xlValues 'Table C0 Part 2.2
    
    SheetC1.Range("T4:U22").Copy
    SheetDest.Range("J2:K20").PasteSpecial xlValues 'Table C0 Part 2.3
    
    SheetC1.Range("W4:X22").Copy
    SheetDest.Range("L2:M20").PasteSpecial xlValues 'Table C0 Part 2.4
    
    SheetC1.Range("Z4:AA22").Copy
    SheetDest.Range("N2:O20").PasteSpecial xlValues 'Table C0 Part 2.5
    
    ' 处理日期匹配与KPI写入逻辑
    ' 先读取原始值，避免格式转换误差
    DataDate = SheetC1.Range("C2").Value
    kpiValue = SheetC1.Range("AD27").Value
    
    ' 遍历SheetDest第2行的21-100列
    For i = 21 To 100
        ' 统一转换为Date类型进行比较，兼容常规/文本格式的日期
        If IsDate(SheetDest.Cells(2, i).Value) And IsDate(DataDate) Then
            If CDate(SheetDest.Cells(2, i).Value) = CDate(DataDate) Then
                ' 明确指定写入SheetDest的对应单元格
                SheetDest.Cells(3, i).Value = kpiValue
                ' 找到匹配项后退出循环，提升效率
                Exit For
            End If
        End If
    Next i
    
    ' 清除剪贴板，避免Excel保留复制状态
    Application.CutCopyMode = False
End Sub

关键修正说明 #

• 移除错误的Exit For：删除原代码Else分支的Exit For，确保遍历所有目标列；找到匹配项后再主动退出循环，提升效率
• 明确工作表对象：所有单元格操作都指定SheetDest，避免依赖当前激活工作表导致的写入错误
• 兼容日期格式：使用IsDate判断有效性，再用CDate统一转换为日期类型进行比较，解决常规/文本格式日期的匹配问题
• 优化资源占用：添加Application.CutCopyMode = False清除剪贴板，释放Excel资源

内容的提问来源于stack exchange，提问作者2mas