求助：用VBA实现Excel图表数据的开放式格式化

我研究这个问题很久了，目前遇到瓶颈。正在尝试在Excel中格式化数据用于制作图表，原始数据是故障类型对应日期的列表，期望输出是故障类型为行、日期为列的交叉统计表，统计每种故障在对应日期的出现次数。因为故障数量和日期范围差异很大，需要实现开放式处理来完整检索导入的文件，而且不能依赖公式，现在用VBA实现了初步代码，希望得到改进建议。

现有代码 #

Sub Graph()

Dim GraphDataWS, DataWS, FormWS As Worksheet
Dim criteria1, InspectedMtr As String
Dim totalrow, ErrorRangevar, DateRangeVar, Row1, Col1 As Long
Dim Daterange, ErrorRange As Range
Dim criteria2 As Variant
Dim ErrorCount, Output As Double

Worksheets("Graph Data").Activate

Set Worksheet = ActiveWorkbook.Sheets("Graph Data")

Cells.Select
Selection.ClearContents
Selection.ClearContents

Set GraphDataWS = ActiveWorkbook.Sheets("Graph Data")
Set FormWS = ActiveWorkbook.Sheets("Formulas")
Set DataWS = ActiveWorkbook.Sheets("Data")

totalrow = FormWS.Range("A21").Value

Worksheets("Data").Range("A1:A" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("B1"))
Worksheets("Data").Range("E1:E" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("A1"))

With GraphDataWS
ErrorRangevar = GraphDataWS.Cells(Rows.Count, "A").End(xlUp).Row
GraphDataWS.Range("A1:A" & ErrorRangevar).Copy (GraphDataWS.Range("C1:C" & ErrorRangevar))
GraphDataWS.Range("C2:C" & ErrorRangevar).RemoveDuplicates Columns:=1
DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).Row
GraphDataWS.Range("B1:B" & DateRangeVar).Copy (GraphDataWS.Range("D1:D" & DateRangeVar))
GraphDataWS.Range("D2:D" & DateRangeVar).RemoveDuplicates Columns:=1

'DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).row

Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True


ErrorRangevar = ErrorRangevar + 2

Worksheets("Graph Data").Activate
Output = 0

Set Daterange = GraphDataWS.Range(Cells(1, 4), Cells(1, DateRangeVar))
Set ErrorRange = GraphDataWS.Range("C1:C" & ErrorRangevar)

For a = 2 To ErrorRangevar

criteria1 = Cells(a, 3).Value

For b = 2 To ErrorRangevar

criteria2 = Cells(a, 4).Value


For i = 2 To ErrorRangevar
        If ((Cells(i, 1)) = criteria1) And (Cells(i, 2) = criteria2) Then
            Output = Output + 1
        End If
Next i

Row1 = ErrorRange.Find(What:=criteria1).Row
Col1 = Daterange.Find(What:=criteria2).Column


Cells(Row1, Col1).Value = Output

MsgBox criteria1 & " " & Row1 & " " & criteria2 & " " & Col1 & " Output: " & Output
Output = 0
Next b
Next a

GraphDataWS.Range("E2").Value = Output

End With

End Sub

代码优化建议 #

• 规范变量声明：VBA中变量声明默认是Variant类型，Dim GraphDataWS, DataWS, FormWS As Worksheet仅最后一个变量为Worksheet类型，前两个是Variant，需改为每个变量单独指定类型，例如：Dim GraphDataWS As Worksheet, DataWS As Worksheet, FormWS As Worksheet，避免类型不匹配错误。
• 移除Select/Activate操作：这类操作不仅降低运行效率，还容易因工作表切换出错。直接通过工作表对象操作单元格，比如将Worksheets("Graph Data").Activate+Cells.Select+Selection.ClearContents简化为GraphDataWS.Cells.ClearContents（原代码重复执行了两次ClearContents，需删除一次）。
• 优化三重循环：当前三重循环时间复杂度为O(n³)，数据量大时运行极慢。推荐使用Scripting.Dictionary提前统计故障与日期的组合出现次数，再一次性填充到交叉表，将时间复杂度降至O(n)。
• 严谨定义单元格范围：代码中Set Daterange = GraphDataWS.Range(Cells(1, 4), Cells(1, DateRangeVar))的Cells未指定工作表，若当前激活工作表不是GraphDataWS会出错，需改为GraphDataWS.Cells。
• 简化去重逻辑：复制后去重的操作可以用Dictionary直接提取唯一值，无需先复制再去重，减少工作表交互次数。
• 移除调试代码：MsgBox属于调试用代码，正式运行时需删除或注释，避免频繁弹窗干扰。
• 添加错误处理：可增加工作表存在性判断、数据范围有效性检查等基础错误处理，避免因工作表名称错误、数据为空导致程序崩溃。

优化后的示例代码 #

Sub Graph_Improved()
    Dim GraphDataWS As Worksheet, DataWS As Worksheet, FormWS As Worksheet
    Dim totalrow As Long, i As Long
    Dim faultDict As Object, dateDict As Object
    Dim faultKey As String, dateKey As String, comboKey As String
    Dim faultList As Variant, dateList As Variant
    Dim countArr() As Long
    
    ' 初始化字典对象（用于存唯一值和统计次数）
    Set faultDict = CreateObject("Scripting.Dictionary")
    Set dateDict = CreateObject("Scripting.Dictionary")
    
    ' 绑定工作表对象
    On Error Resume Next
    Set GraphDataWS = ThisWorkbook.Sheets("Graph Data")
    Set FormWS = ThisWorkbook.Sheets("Formulas")
    Set DataWS = ThisWorkbook.Sheets("Data")
    On Error GoTo 0
    
    ' 检查工作表是否存在
    If GraphDataWS Is Nothing Or FormWS Is Nothing Or DataWS Is Nothing Then
        MsgBox "指定工作表不存在，请检查名称！", vbExclamation
        Exit Sub
    End If
    
    ' 清空目标工作表
    GraphDataWS.Cells.ClearContents
    
    ' 获取数据总行数
    totalrow = FormWS.Range("A21").Value
    If totalrow < 2 Then
        MsgBox "数据行数不足！", vbExclamation
        Exit Sub
    End If
    
    ' 遍历可见数据行，统计故障-日期组合次数，提取唯一值
    For i = 2 To totalrow
        If Not DataWS.Rows(i).Hidden Then
            faultKey = DataWS.Cells(i, "E").Value
            dateKey = DataWS.Cells(i, "A").Value
            
            ' 记录唯一故障类型（行索引从2开始）
            If Not faultDict.Exists(faultKey) Then
                faultDict.Add faultKey, faultDict.Count + 2
            End If
            
            ' 记录唯一日期（列索引从2开始）
            If Not dateDict.Exists(dateKey) Then
                dateDict.Add dateKey, dateDict.Count + 2
            End If
            
            ' 统计组合出现次数
            comboKey = faultKey & "|" & dateKey
            If faultDict.Exists(comboKey) Then
                faultDict(comboKey) = faultDict(comboKey) + 1
            Else
                faultDict.Add comboKey, 1
            End If
        End If
    Next i
    
    ' 将字典键转换为数组
    faultList = faultDict.Keys
    dateList = dateDict.Keys
    
    ' 写入故障类型到左侧行
    For i = 0 To UBound(faultList)
        If InStr(faultList(i), "|") = 0 Then ' 排除组合键
            GraphDataWS.Cells(faultDict(faultList(i)), 1).Value = faultList(i)
        End If
    Next i
    
    ' 写入日期到顶部列（转置为横向）
    GraphDataWS.Range("B1").Resize(1, dateDict.Count).Value = dateList
    
    ' 初始化计数数组
    ReDim countArr(1 To faultDict.Count, 1 To dateDict.Count)
    
    ' 填充计数数组
    For i = 0 To UBound(faultList)
        If InStr(faultList(i), "|") > 0 Then
            Dim parts() As String
            parts = Split(faultList(i), "|")
            faultKey = parts(0)
            dateKey = parts(1)
            ' 将计数写入对应位置
            If faultDict.Exists(faultKey) And dateDict.Exists(dateKey) Then
                countArr(faultDict(faultKey) - 1, dateDict(dateKey) - 1) = faultDict(faultList(i))
            End If
        End If
    Next i
    
    ' 将计数数组写入工作表
    GraphDataWS.Range("B2").Resize(UBound(countArr, 1), UBound(countArr, 2)).Value = countArr
End Sub

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