使用循环将单元格地址存储到vba中的数组中

Question

我正在尝试编写一个代码，该代码利用系统通过使用 for 循环检查两个不同的工作表，并将第二个工作表（“版本 2”）中所做的差异/编辑突出显示到第一个工作表（“原始” )。我有一种感觉，我需要使用一个数组，但我还不够先进，我知道如何存储这些值，然后将它们写到另一张纸上（在下面）。

我已经获得了代码，以便它突出显示所有相关单元格，但现在我正在尝试将其输出到一个报告中（在另一个名为“记录的更改”的工作表上），该报告将总结所有编辑所在的单元格地址制成。请原谅所有变量，因为这是来自未明确定义变量的旧代码集：

Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer

o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0

Sheets("Original").Select
    
For i = 2 To p
    For k = 1 To o
        If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
            If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
                Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
                change = change + 1
            End If
        Else
            If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
                Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
                change = change + 1
            End If
        End If
    Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty

answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)

If answer = vbYes Then
    If Sheet_Exists("Logged Changes") = False Then
        Sheet_Name = "Logged Changes"
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
    End If
    Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
    Unload Me
End If
End Sub

我尝试过修改代码，但不想用任何不必要的/断行的行来阻塞它。任何帮助将不胜感激！

Answer 1

工作表差异

Option Explicit

Sub logChanges()

    Const ws1Name As String = "Original"
    Const ws2Name As String = "Version 2"
    Const wsResult As String = "Logged Changes"
    Const FirstRow As Long = 2
    Const FirstColumn As Long = 1
    Const LastRowColumn As Long = 1
    Const LastColumnRow As Long = 2
    Const ResultFirstCell As String = "A2"
    Dim Headers As Variant
    Headers = Array("Id", "Address", "Original", "Version 2")
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
    Dim LastColumn As Long
    LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
                    .End(xlToLeft).Column
    
    Dim rng As Range
    Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
                        ws.Cells(LastRow, LastColumn))
    Dim Data1 As Variant: Data1 = rng.Value
    
    Set ws = wb.Worksheets(ws2Name)
    Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
    
    Dim Result() As Variant
    Dim i As Long, j As Long, k As Long
    For i = 1 To UBound(Data1)
        For j = 1 To UBound(Data1, 2)
            If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
        Next j
    Next i
    
    If k > 0 Then
        transpose2D Result
        On Error GoTo MissingResultSheet
        Set ws = wb.Worksheets(wsResult)
        On Error GoTo 0
        ws.Range(ws.Range(ResultFirstCell), _
                 ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
        ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
        MsgBox "Found '" & k & "' difference(s) in range '" _
          & rng.Address(False, False) & "'.", vbInformation
    Else
        MsgBox "Found no differences in range '" _
          & rng.Address(False, False) & "'.", vbExclamation
    End If
    
    Exit Sub
    
writeResult:
    k = k + 1
    ReDim Preserve Result(1 To 4, 1 To k)
    Result(1, k) = k
    Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
    Result(3, k) = Data1(i, j)
    Result(4, k) = Data2(i, j)
    Return

MissingResultSheet:
    If Err.Number = 9 Then
        wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
        With ActiveSheet
            .Name = wsResult
            If .Range(ResultFirstCell).Row > 1 Then
               .Range(ResultFirstCell).Offset(-1) _
                 .Resize(, UBound(Headers) + 1).Value = Headers
            End If
        End With
        Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
    Else
        '?
        Exit Sub
    End If

End Sub

Function getAddress(aRow As Long, aColumn As Long) As String
    getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function

Sub transpose2D(ByRef Data As Variant)
    Dim i As Long, j As Long
    Dim Result As Variant
    ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
                 LBound(Data) To UBound(Data))
    For i = LBound(Data) To UBound(Data)
        For j = LBound(Data, 2) To UBound(Data, 2)
            Result(j, i) = Data(i, j)
        Next j
    Next i
    Data = Result
End Sub

这种不使用对象Function to convert column number to letter? 将列号转换为字符串的解决方案可用于编写下降getAddress 函数。

Answer 2

试试这个：

Option Explicit

Private Sub CompareBasic()
    Const SHT_REPORT As String = "Logged Changes"
    Dim actSheet As Range
    Dim c As Integer
    Dim o As Long
    Dim p As Long
    Dim r As Long
    Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
    Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
    Dim arrUpdates
    
    Set wsOrig = Worksheets("Original")
    Set wsNew = Worksheets("Version 2")
    
    o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
    p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
    
    Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
    dataOrig = rngData.Value                           'get an array of data
    dataNew = wsNew.Range(rngData.Address).Value       'array of new data
    ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
    change = 0
    
    For r = 1 To UBound(dataOrig, 1)
        For c = 1 To UBound(dataOrig, 2)
            v1 = dataOrig(r, c)
            v2 = dataNew(r, c)
            If Len(v1) > 0 Or Len(v2) > 0 Then
                If IsNumeric(v1) Then
                    bDiff = v1 <> v2
                Else
                    bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
                End If
            End If
            'any difference?
            If bDiff Then
                change = change + 1
                With rngData.Cells(r, c)
                    arrUpdates(change, 1) = .Address
                    .Interior.ColorIndex = 37
                End With
                arrUpdates(change, 2) = v1
                arrUpdates(change, 3) = v2
            End If
        Next c
    Next r
    
    If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
        With GetSheet(SHT_REPORT, ThisWorkbook)
            .UsedRange.ClearContents
            .Range("A1") = "Edited Requirements"
            .Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
            .Range("A4").Resize(change, 3).Value = arrUpdates
        End With
    Else
        'Unload Me
    End If
End Sub

'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
    Dim rv As Worksheet
    On Error Resume Next
    Set rv = wb.Worksheets(wsName)
    On Error GoTo 0
    If rv Is Nothing Then
        Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        rv.Name = "Logged Changes"
    End If
    Set GetSheet = rv
End Function