时间戳

首页 > 解决方案 > 比较两个 Excel 工作表时 VBA 代码不断崩溃

excel - 比较两个 Excel 工作表时 VBA 代码不断崩溃

问题描述

我编写了一个 VBA 代码来比较包含我公司订单信息的两张表的内容。这就是我想要完成的事情

  1. 如果订单在新工作表中但不在旧工作表中，则突出显示新工作表中的整行。
  2. 如果现有订单的订单信息已从旧表更改（例如交货日期），请在新表中突出显示更改的单元格。

下面是我的代码，但 For 循环在 1000 行后不断崩溃……我觉得我的代码效率低下。我是 Excel VBA 的新手，所以我非常感谢任何帮助。

Private Sub test()

    Sheets("New Sheet").Select
    Row = 2
    Cells(Row, 1).Select
    
    Dim cell As Range
    Dim BigCell As Range
    
    For i = 1 To 3000
        If Not IsEmpty(ActiveCell.Offset(0, 2)) Then 'Run check if Column C is not blank
            PIModel = ActiveCell.Value
                
            Sheets("Old Sheet").Select
            Columns("A:A").Select
            Set findPIModel = Selection.Find(What:=PIModel, After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            
            If (findPIModel Is Nothing) Then
                Sheets("New Sheet").Select
                ActiveCell.Columns("A:X").Interior.ColorIndex = 37
                
                Row = Row + 1
                Cells(Row, 1).Select
            Else
                findPIModel.Activate
                'Skipping a few columns because I don't need to run check on all of them
                Column = 19
                Columnoffset = 18
                
                For Each cell In Sheets("New Sheet").Range("A1:P1")
                    If Not Worksheets("New Sheet").Cells(Row, Column).Value = ActiveCell.Offset(0, Columnoffset).Value Then
                        Worksheets("New Sheet").Select
                        Cells(Row, Column).Interior.ColorIndex = 37
                        
                        Column = Column + 1
                        Columnoffset = Columnoffset + 1
                        
                        Worksheets("Old Sheet").Select
                        Cells(Row, 1).Select
                    End If
                Next
            
                Row = Row + 1
                Sheets("New Sheet").Select
                Cells(Row, 1).Select
            End If
        Else: Exit For
        End If
    Next i
End Sub

标签： excelvba

解决方案

这是一个可能比您的代码大一点的代码，但肯定会更快，更有效地工作。该代码已被注释，所以它应该足以让你玩弄它。

Option Explicit
Sub Test()
    
    'First we are going to store the old sheet in a dictionary
    'For That you need to go to Tools->References->Check the "Microsoft Scripting Runtime" library
    'To learn more about dictionaries, how to use them and why: http://www.snb-vba.eu/VBA_Dictionary_en.html
    Dim OldSheet As Dictionary
    Set OldSheet = LoadOldSheet(ThisWorkbook.Sheets("Old Sheet").UsedRange.Value)
    
    'Now we store the new sheet inside an array (to work faster)
    'To learn more about arrays, how to use them and why: http://www.snb-vba.eu/VBA_Arrays_en.html
    Dim arr As Variant: arr = ThisWorkbook.Sheets("New Sheet").UsedRange.Value
    Dim MyString As String
    Dim HighLightRange As Range
    Dim i As Long
    'Now we loop through the new sheet finding the rows which will not match with the old sheet
    For i = 2 To UBound(arr)
        If arr(i, 1) = vbNullString Then Exit For
        For j = 1 To 16
            MyString = MyString & LCase(arr(i, j))
        Next j
        'If the row doesn't match with the old sheet then we store the range A:P for that row in a variable
        If Not OldSheet.Exists(MyString) Then
            With ThisWorkbook.Sheets("New Sheet")
                If HighLightRange Is Nothing Then
                    Set HighLightRange = .Range("A" & i & ":P" & i)
                Else
                    Set HighLightRange = Union(HighLightRange, .Range("A" & i & ":P" & i))
                End If
            End If
        MyString = vbNullString
    Next i
    'When we stored all the rows which won't match, highlight them all at once
    If Not HighLightRange.Range Is Nothing Then HighLightRange.Interior.ColorIndex = 37

End Sub
Private Function LoadOldSheet(arr As Variant) As Dictionary
    'How we are going to load the old sheet in a dictionary is simple,
    'we store the columns A to P as the key (in Low Case)
    
    Set LoadOldSheet = New Dictionary
    Dim i As Long, j As Long
    Dim MyString As String 'A PlaceHolder variable to store all the columns at once
    'Note that I'm starting at row 2 counting that you have headers in row 1
    For i = 2 To UBound(arr)
        'Here I'm counting that in the old sheet all your rows in column A are filled.
        'If not, the function will end where it finds a blank cell.
        If arr(i, 1) = vbNullString Then Exit For
        '(1 is index number for column A and 16 is index number for column P)
        For j = 1 To 16
            MyString = MyString & LCase(arr(i, j))
        Next j
        'Here we store the whole range A:P from the row we are in
        LoadOldSheet.Add MyString, 1
        'Reset the variable
        MyString = vbNullString
    Next i
    
End Function

推荐阅读