vba Sub CompareTwoOpenWorkbooks() Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim val1 As String, val2 As String Dim wbCount As Long '检测打开的Excel文件数量，仅允许两个文件对比 wbCount = Workbooks.Count If wbCount <> 2 Then MsgBox "请只打开【两个】需要对比的Excel文件！当前打开数量：" & wbCount, vbExclamation Exit Sub End If '自动识别两个已打开的Excel文件 Dim wb As Workbook Dim index As Long index = 0 For Each wb In Workbooks index = index + 1 If index = 1 Then Set wb1 = wb If index = 2 Then Set wb2 = wb Next wb '绑定两个文件的第一个工作表 On Error Resume Next Set ws1 = wb1.Worksheets(1) Set ws2 = wb2.Worksheets(1) On Error GoTo 0 '判断工作表是否加载成功 If ws1 Is Nothing Or ws2 Is Nothing Then MsgBox "工作表获取失败，请检查文件是否存在有效工作表！", vbCritical Exit Sub End If '获取第一个表格的有效数据区域 lastRow = ws1.UsedRange.Rows.Count lastCol = ws1.UsedRange.Columns.Count '关闭屏幕刷新，提升运行速度 Application.ScreenUpdating = False '清除目标表格原有黄色标注，避免旧标记干扰 ws2.UsedRange.Interior.ColorIndex = xlNone '双层循环逐单元格对比数据 For i = 1 To lastRow DoEvents '防止Excel运行卡死 For j = 1 To lastCol '去除首尾空格、统一转为文本格式，避免格式、空格导致的误判 val1 = Trim(CStr(ws1.Cells(i, j).Value)) val2 = Trim(CStr(ws2.Cells(i, j).Value)) '数据不一致则标黄高亮 If val1 <> val2 Then ws2.Cells(i, j).Interior.Color = vbYellow End If Next j Next i '恢复屏幕刷新 Application.ScreenUpdating = True '对比完成提示 End Sub |
