运行multidimensional array并检查工作表中的数据

有一个数组获取单元格颜色的logging加上与该行相关的ID，这是特定于该行。

现在我想通过拾取ID的数组运行，然后使用它与另一个工作表进行比较（使用ID），以查看单元格的颜色是否已更改。

我试图以“黑客”的方式做到这一点，但我不知道如何通过每个数组logging和皮卡ID额外检查。

Sub FindColourChange() 'this first bit is getting the data and putting in array Dim newSheet As Worksheet Dim r As Integer Dim c As Integer Set newSheet = ThisWorkbook.Worksheets("Combine") intRowsNew = newSheet.UsedRange.Rows.Count Dim newColourArray() ReDim Preserve newColourArray(2 To intRowsNew, 7 To 19) For r = 2 To intRowsNew ' this is the number of rows in your range newColourArray(r, 7) = newSheet.Cells(r, 1).Value Debug.Print "New is " & newColourArray(r, 7) & ", " For c = 8 To 19 newColourArray(r, c) = newSheet.Cells(r, c).Interior.ColorIndex Debug.Print "Colour of new is " & newColourArray(r, c) & ", " Next Next 'HERE IS WHERE I AM HAVING ISSUES - TRYING TO GET THE DATA FROM ARRAY TO COMPARE TO THE "Old Data" SHEET but cant figure a way out to go through each individual array record and get the first column value... Dim result As String Dim sheet As Worksheet Set sheet = ActiveWorkbook.Sheets("Old Data") Dim currentRow As Integer 'result = Application.VLookup(newColourArray(r, 1), sheet.Range("A:S"), 8, False) Sheets("Combine").Select For r = 2 To newColourArray Columns("A:A").Select Selection.Find(What:=newColourArray(r, 7), After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False).Activate currentRow = ActiveCell.Row For c = 8 To 19 If newColourArray(r, c) <> oldSheet.Cells(currentRow, c).Interior.ColorIndex Then Sheets("Combine").Select End If Next Next End Sub 

Answer 1

感谢您发表一个新的问题。 我昨天正在考虑这个，下面的代码可能会为你做的伎俩：

 Private Const ID_COLUMN As Integer = 1 Private Const FIRST_VALUE_COLUMN As Integer = 8 Private Const LAST_VALUE_COLUMN As Integer = 19 Private Type RowFields ItemID As Variant ColourOfValues(LAST_VALUE_COLUMN - _ FIRST_VALUE_COLUMN) As Variant SheetRow As Long End Type Private mOldSheet As Worksheet Private mNewSheet As Worksheet Private mOldRowFields() As RowFields Private mNewRowFields() As RowFields Sub RunMe() Set mOldSheet = ThisWorkbook.Worksheets("Old Data") Set mNewSheet = ThisWorkbook.Worksheets("Combine") ' Read the desired values ReadIDsColoursAndValues ' Acquire the cells where there's a colour change AcquireColourChanges End Sub Private Sub ReadIDsColoursAndValues() Dim firstRow As Integer Dim lastRow As Integer Dim r As Long Dim c As Integer Dim rowIndex As Long Dim valueIndex As Integer ' ------------------ ' Read the old sheet ' ------------------ ' Define the row range firstRow = 2 ' change this if different lastRow = mOldSheet.Cells(mOldSheet.Rows.Count, 1).End(xlUp).Row ' Redimension the RowFields array ReDim mOldRowFields(lastRow - firstRow) ' adjust if not zero-based ' Iterate through the rows to acquire data For r = firstRow To lastRow ' Populate the row fields object rowIndex = r - firstRow ' adjust if not zero-based With mOldRowFields(rowIndex) .ItemID = mOldSheet.Cells(r, ID_COLUMN).Value2 .SheetRow = r ' Iterate through the columns to acquire the colours For c = FIRST_VALUE_COLUMN To LAST_VALUE_COLUMN valueIndex = c - FIRST_VALUE_COLUMN ' adjust if not zero-based .ColourOfValues(valueIndex) = _ mOldSheet.Cells(r, c).Interior.ColorIndex Next End With Next ' ------------------ ' Read the new sheet ' ------------------ ' Define the row range firstRow = 2 ' change this if different lastRow = mNewSheet.Cells(mNewSheet.Rows.Count, 1).End(xlUp).Row ' Redimension the RowFields array ReDim mNewRowFields(lastRow - firstRow) ' adjust if not zero-based ' Iterate through the rows to acquire data For r = firstRow To lastRow ' Populate the row fields object rowIndex = r - firstRow ' adjust if not zero-based With mNewRowFields(rowIndex) .ItemID = mNewSheet.Cells(r, ID_COLUMN).Value2 .SheetRow = r ' Iterate through the columns to acquire the colours For c = FIRST_VALUE_COLUMN To LAST_VALUE_COLUMN valueIndex = c - FIRST_VALUE_COLUMN ' adjust if not zero-based .ColourOfValues(valueIndex) = _ mNewSheet.Cells(r, c).Interior.ColorIndex Next End With Next End Sub Private Sub AcquireColourChanges() Dim rowIndex As Long Dim refIndex As Long Dim rowItem As RowFields Dim refItem As RowFields Dim valueIndex As Integer Dim sheetColumn As Integer Dim highlightCells As Range Dim cell As Range For rowIndex = LBound(mNewRowFields, 1) To UBound(mNewRowFields, 1) rowItem = mNewRowFields(rowIndex) ' Find the matching ID RowFields from old sheet For refIndex = LBound(mOldRowFields, 1) To UBound(mOldRowFields, 1) refItem = mOldRowFields(refIndex) If rowItem.ItemID = refItem.ItemID Then ' Check each value colour against the old row For valueIndex = LBound(rowItem.ColourOfValues, 1) To _ UBound(rowItem.ColourOfValues, 1) If rowItem.ColourOfValues(valueIndex) <> _ refItem.ColourOfValues(valueIndex) Then ' Small piece of code to highligh the cells. ' You can do anything you like at this point. sheetColumn = valueIndex + FIRST_VALUE_COLUMN ' adjust if not zero-based Set cell = mNewSheet.Cells(rowItem.SheetRow, sheetColumn) If highlightCells Is Nothing Then Set highlightCells = cell Else Set highlightCells = Union(highlightCells, cell) End If End If Next ' ID was found so we can break the search loop Exit For End If Next Next mNewSheet.Activate If highlightCells Is Nothing Then MsgBox "No values have different colours." Else highlightCells.Select MsgBox "The different coloured values have been highlighted." & vbCrLf & vbCrLf & _ highlightCells.Address(False, False) End If End Sub