Excel 2013 VBA代码修复：标记产品月度联网记录

修复后的VBA代码 #

Sub MarkConnectedBatteries()
    Dim wsData As Worksheet, wsReport As Worksheet
    Dim tblData As ListObject
    Dim dataArr As Variant, reportArr As Variant
    Dim dateCol As Integer, modelCol As Integer
    Dim modelDict As Object
    Dim i As Long, j As Long
    Dim model As String, connectYearMonth As String
    Dim targetYearMonth As String
    Dim lastModelRow As Long, lastMonthCol As Integer
    
    ' 绑定工作表与数据表格
    Set wsData = ThisWorkbook.Worksheets("Seznam_izdelanih_baterij")
    Set tblData = wsData.ListObjects("Tabela2")
    Set wsReport = ThisWorkbook.Worksheets("Tabela priklopov po mesecih")
    Set modelDict = CreateObject("Scripting.Dictionary")
    
    ' 通过表头确定列位置，避免列顺序变动出错
    modelCol = tblData.ListColumns("Tip baterije").Index
    dateCol = tblData.ListColumns("Datum priklopa").Index
    
    ' 读取数据到数组，提升处理效率
    dataArr = tblData.DataBodyRange.Value
    
    ' 构建型号-年月映射字典
    For i = 1 To UBound(dataArr, 1)
        model = Trim(dataArr(i, modelCol))
        If Not IsEmpty(dataArr(i, dateCol)) And IsDate(dataArr(i, dateCol)) Then
            connectYearMonth = Format(dataArr(i, dateCol), "yyyy-mm")
            If Not modelDict.Exists(model) Then
                modelDict.Add model, CreateObject("Scripting.Dictionary")
            End If
            modelDict(model)(connectYearMonth) = True
        End If
    Next i
    
    ' 获取Sheet2的数据范围
    With wsReport
        lastModelRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        lastMonthCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
        If lastModelRow < 4 Or lastMonthCol < 3 Then Exit Sub
        reportArr = .Range(.Cells(3, "C"), .Cells(lastModelRow, lastMonthCol)).Value
    End With
    
    ' 遍历匹配并标记
    For i = 2 To UBound(reportArr, 1)
        model = Trim(wsReport.Cells(i + 2, "B").Value)
        If modelDict.Exists(model) Then
            For j = 1 To UBound(reportArr, 2)
                targetYearMonth = Trim(reportArr(1, j))
                reportArr(i, j) = IIf(modelDict(model).Exists(targetYearMonth), "X", "")
            Next j
        Else
            For j = 1 To UBound(reportArr, 2)
                reportArr(i, j) = ""
            Next j
        End If
    Next i
    
    ' 将结果写回Sheet2
    wsReport.Range(wsReport.Cells(3, "C"), wsReport.Cells(lastModelRow, lastMonthCol)).Value = reportArr
    
    MsgBox "匹配完成！", vbInformation
End Sub

代码关键说明 #

• 字典优化查询：用双层Scripting.Dictionary存储每个型号对应的所有联网年月，避免重复遍历数据，大幅提升匹配效率。
• 数组批量处理：将数据读取到数组后再操作，比直接遍历单元格快数倍，减少Excel界面交互开销。
• 列位置容错：通过表头名称定位列，而非固定列号，避免因列顺序调整导致代码失效。
• 年月格式统一：代码默认用yyyy-mm格式提取年月，若Sheet2第3行的年月格式为mm/yyyy，只需修改Format函数的参数为"mm/yyyy"即可。

注意事项 #

1. 宏权限设置：需在Excel的信任中心开启宏功能，否则代码无法运行。
2. 格式一致性：Sheet2第3行的年月需与代码中生成的格式完全匹配，否则会出现匹配失败。
3. 数据有效性：确保Sheet1的S列是有效日期格式，无效日期会被自动跳过。
4. 表格类型适配：若Tabela2是普通单元格区域而非结构化表格，需将tblData.DataBodyRange.Value替换为wsData.Range("D2:S" & wsData.Cells(wsData.Rows.Count, "D").End(xlUp).Row).Value。

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