创build一个macros来比较同一工作表中不同列的单元格值

我正在试图做一个macros观的，将以系统的方式比较细胞的价值。 我有2个数据集。 我打算创build的macros将基本上将“C3：M25”的值与“O3：Y25”的值进行比较。

我的macros应该开始比较范围（“C3”）和范围（“O3”）的值。 如果C3.value> O3.value，则会改变interior.colourindex.value和字体颜色

一旦完成第一次比较，它将下移到下一行，即比较范围（“C4”）的值与范围（“O4”）。 该过程继续进行，直至遇到列中的第一个空白行，在这种情况下，范围（“C26”）。

一旦范围（“C26”）是一个空单元格，那么macros将重复比较过程，但是这次它将基本上将范围（“D3”）中的值与范围（“P3”）进行比较。 循环一直持续到整个过程完成。

Sub ilovetocompare() Dim ross As Long, colss As Long Dim wb As Workbook, ws1 As Long, ws1row As Integer Set wb = ActiveWorkbook.Sheets("Pricer") wb.Range("C3").Activate With ActiveCell ws1row = Worksheets("pricer").Range("B3").End(xlDown).Rows.Count 'get the last row count 'macro will stop when it detects that the cells is filled with other colors Do Until ActiveCell.Interior.Color = 255 'start comparing the prices For ross = 3 To ws1row For colss = 15 To 25 ' number of columns will remain unchanged If ActiveCell.Value > Cells(ross, colss).Value Then ActiveCell.Font.Bold = True ActiveCell.Font.colour = vbWhite 'once done with comparison, jump to the next row ActiveCell.Offset(1, 0).Activate 'the column O likewise also move 1 row down for comparison Next ross 'when the it hits an empty row, the activecell got readjusted back to the top ElseIf ActiveCell.Value = "" Then ActiveCell.Offset(-ws1row, 1).Select With Selection Loop 'move the cell up again so that i can resume the comparsion 'create this into a loop End Sub 

Answer 1

这里有个build议：

 Private Sub macrobygiada() ColumnoneStart = 3 ' C ColumnoneEnd = 13 'M ColumntwoStart = 15 'O Set wb = ActiveWorkbook.Sheets("Pricer") TotalColumn = ColumnoneEnd - ColumnoneStart 'difference of the columnnumber C to M (3 to 13) For Column = 1 To TotalColumn 'number of columns For Cell = 3 To 25 'go through the Cells If (Cells(Cell, ColumnoneStart).Value > Cells(Cell, ColumntwoStart).Value) Then wb.Cells(Cell, ColumnoneStart).Font.Bold = True wb.Cells(Cell, ColumnoneStart).Font.ColorIndex = 2 'colour white End If Next ColumnoneStart = ColumnoneStart + 1 ColumntwoStart = ColumntwoStart + 1 Next Set wb = Nothing End Sub 

问候