VBA对比多Excel文件后结果未显示，请求问题排查

核心问题分析 #

你的代码存在三个致命逻辑错误，导致当前工作表始终空白：

1. 数据写入对象错误：修改后的dataA数组被写回了源文件a.xlsx的工作表，但后续关闭该文件时设置了SaveChanges:=False，等于丢弃所有修改，且全程未向当前运行VBA的工作表写入任何内容。
2. 数组列删除函数逻辑错误：DeleteColumnsFromArray中计算新数组列索引的方式j - (j > UBound(columnsToDelete))完全错误，会导致列数据错位、数组越界，实际处理后的数据结构已损坏。
3. 全局错误屏蔽：开头的On Error Resume Next会掩盖所有运行时错误，包括数组越界、工作表引用失败等问题，无法通过日志发现这些底层错误。

修复后的完整代码 #

Option Explicit

Sub CompareAndModifyFiles()
    ' 性能优化设置
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim filePath As String
    Dim logFilePath As String
    Dim logFileNumber As Integer
    Dim wbA As Workbook, wbB As Workbook, wbC As Workbook, wbD As Workbook
    Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
    Dim wsCurrent As Worksheet ' 当前运行VBA的工作表
    Dim i As Long
    Dim dataA As Variant, dataB As Variant, dataC As Variant, dataD As Variant
    Dim maxVal As Variant, minVal As Variant, avgVal As Variant
    Dim columnToCheck As Long
    Dim newColIndex As Long
    
    ' 绑定当前工作表（可改为指定工作表，比如ThisWorkbook.Sheets("结果表")）
    Set wsCurrent = ThisWorkbook.ActiveSheet
    ' 清空当前工作表原有数据
    wsCurrent.Cells.Clear
    
    ' 设置文件路径
    filePath = "C:\Users\kelvin.how\Downloads\"
    logFilePath = filePath & "Log.txt"
    
    ' 打开日志文件
    logFileNumber = FreeFile
    Open logFilePath For Output As logFileNumber
    LogMessage logFileNumber, "对比操作开始: " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
    
    ' 打开源文件（局部错误处理）
    On Error Resume Next
    Set wbA = Workbooks.Open(filePath & "a.xlsx")
    Set wbB = Workbooks.Open(filePath & "b.xlsx")
    Set wbC = Workbooks.Open(filePath & "c.xlsx")
    Set wbD = Workbooks.Open(filePath & "d.xlsx")
    On Error GoTo 0
    
    ' 检查所有文件是否成功打开
    If wbA Is Nothing Or wbB Is Nothing Or wbC Is Nothing Or wbD Is Nothing Then
        LogMessage logFileNumber, "错误：部分源文件无法打开"
        GoTo Cleanup
    End If
    
    ' 遍历wbA的工作表
    For Each wsA In wbA.Sheets
        Set wsB = GetSheetIfExists(wbB, wsA.Name)
        Set wsC = GetSheetIfExists(wbC, wsA.Name)
        Set wsD = GetSheetIfExists(wbD, wsA.Name)
        
        If Not (wsB Is Nothing) And Not (wsC Is Nothing) And Not (wsD Is Nothing) Then
            ' 读取源数据
            dataA = wsA.UsedRange.Value
            dataB = wsB.UsedRange.Value
            dataC = wsC.UsedRange.Value
            dataD = wsD.UsedRange.Value
            
            ' 删除指定列（修复后的函数）
            dataA = DeleteColumnsFromArray(dataA, Array(2, 3, 4, 8, 9, 10, 11, 15, 16, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
                                                        31, 32, 33, 34, 35, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, _
                                                        52, 53, 54, 55, 56, 57))
            
            ' 遍历数据行（从第2行开始，跳过表头）
            For i = 2 To UBound(dataA, 1)
                For columnToCheck = LBound(dataA, 2) To UBound(dataA, 2)
                    ' 确保其他文件的对应列存在
                    If columnToCheck <= UBound(dataB, 2) And _
                       columnToCheck <= UBound(dataC, 2) And _
                       columnToCheck <= UBound(dataD, 2) Then
                        
                        ' 计算统计值（加入错误处理）
                        On Error Resume Next
                        maxVal = Application.WorksheetFunction.Max(dataA(i, columnToCheck), _
                                                                   dataB(i, columnToCheck), _
                                                                   dataC(i, columnToCheck), _
                                                                   dataD(i, columnToCheck))
                        minVal = Application.WorksheetFunction.Min(dataA(i, columnToCheck), _
                                                                   dataB(i, columnToCheck), _
                                                                   dataC(i, columnToCheck), _
                                                                   dataD(i, columnToCheck))
                        avgVal = Application.WorksheetFunction.Average(dataA(i, columnToCheck), _
                                                                       dataB(i, columnToCheck), _
                                                                       dataC(i, columnToCheck), _
                                                                       dataD(i, columnToCheck))
                        On Error GoTo 0
                        
                        ' 判断并修改数据
                        If maxVal = minVal And minVal = avgVal Then
                            LogMessage logFileNumber, "行" & i & ",列" & columnToCheck & ": 所有文件值一致"
                        Else
                            LogMessage logFileNumber, "行" & i & ",列" & columnToCheck & ": 值差异 - 最大值:" & maxVal & ",最小值:" & minVal & ",平均值:" & avgVal
                            ' 根据列规则修改值
                            Select Case columnToCheck
                                Case 37
                                    dataA(i, columnToCheck) = IIf(IsNumeric(avgVal), avgVal, "")
                                Case 38
                                    dataA(i, columnToCheck) = IIf(IsNumeric(minVal), minVal, "")
                                Case 39
                                    dataA(i, columnToCheck) = IIf(IsNumeric(maxVal), maxVal, "")
                                Case Else
                                    ' 其他列可自定义处理逻辑
                            End Select
                        End If
                    End If
                Next columnToCheck
            Next i
            
            ' 将处理后的数据写入当前工作表（追加方式，支持多工作表结果）
            wsCurrent.Cells(wsCurrent.UsedRange.Row + wsCurrent.UsedRange.Rows.Count, 1).Resize(UBound(dataA, 1), UBound(dataA, 2)).Value = dataA
            ' 写入工作表分隔标记
            wsCurrent.Cells(wsCurrent.UsedRange.Row + wsCurrent.UsedRange.Rows.Count, 1).Value = "--- " & wsA.Name & " 数据结束 ---"
        Else
            LogMessage logFileNumber, "缺失对应工作表: " & wsA.Name
        End If
    Next wsA
    
    ' 删除不需要的行示例：删除所有值全为空的行（可根据需求修改条件）
    For i = wsCurrent.UsedRange.Rows.Count To 2 Step -1
        If Application.WorksheetFunction.CountA(wsCurrent.Rows(i)) = 0 Then
            wsCurrent.Rows(i).Delete
            LogMessage logFileNumber, "删除空白行: " & i
        End If
    Next i

Cleanup:
    ' 关闭源文件（不保存修改）
    If Not wbA Is Nothing Then wbA.Close SaveChanges:=False
    If Not wbB Is Nothing Then wbB.Close SaveChanges:=False
    If Not wbC Is Nothing Then wbC.Close SaveChanges:=False
    If Not wbD Is Nothing Then wbD.Close SaveChanges:=False
    
    ' 日志收尾
    LogMessage logFileNumber, "对比操作结束: " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
    Close logFileNumber
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "处理完成，结果已写入当前工作表", vbInformation
End Sub

Sub LogMessage(logFileNumber As Integer, message As String)
    Print #logFileNumber, message
    Debug.Print message
End Function

Function GetSheetIfExists(wb As Workbook, sheetName As String) As Worksheet
    On Error Resume Next
    Set GetSheetIfExists = wb.Sheets(sheetName)
    On Error GoTo 0
End Function

Function DeleteColumnsFromArray(dataArray As Variant, columnsToDelete As Variant) As Variant
    Dim i As Long, j As Long
    Dim newDataArray As Variant
    Dim newColIndex As Long
    
    ' 计算保留的列数
    Dim keepColCount As Long
    keepColCount = UBound(dataArray, 2) - (UBound(columnsToDelete) - LBound(columnsToDelete) + 1)
    ReDim newDataArray(1 To UBound(dataArray, 1), 1 To keepColCount)
    
    For i = LBound(dataArray, 1) To UBound(dataArray, 1)
        newColIndex = 1
        For j = LBound(dataArray, 2) To UBound(dataArray, 2)
            If Not IsInArray(j, columnsToDelete) Then
                newDataArray(i, newColIndex) = dataArray(i, j)
                newColIndex = newColIndex + 1
            End If
        Next j
    Next i
    
    DeleteColumnsFromArray = newDataArray
End Function

Function IsInArray(value As Variant, arr As Variant) As Boolean
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next i
End Function

关键修复点说明 #

• 数据写入目标修正：新增wsCurrent绑定当前运行VBA的工作表，将处理后的dataA写入该表，而非源文件。
• 数组列删除逻辑修复：用newColIndex逐列计数的方式构建新数组，彻底解决列错位问题。
• 错误处理优化：移除全局On Error Resume Next，改为局部错误处理，避免掩盖关键错误。
• 新增行删除逻辑：实现了空白行删除（可根据需求修改删除条件），满足删除不需要行的需求。
• 多工作表结果追加：如果源文件有多个工作表，结果会自动追加到当前工作表，并标记分隔。

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