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

如何解决使用循环将单元格地址存储到VBA中的数组中

我正在尝试使用一个代码，该代码利用系统通过使用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,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

我尝试摆弄代码，但不想用任何不必要的/断行堵塞它。任何帮助将不胜感激！

解决方法

尝试一下：

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,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

,

纸张差异

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
        Call 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,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)
            Result(j,i) = Data(i,j)
        Next j
    Next i
    Data = Result
End Sub

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