对一列中的单元格中的具有特定值的所有行运行VBA

Question

首先 - 我不是VBA专家，可以称自己为中级excel用户。我有一个广泛的VBA宏，我试图应用到仅有约数百行中的55行。

然后，我想运行相同的宏对另一组具有与以前相同的列中的不同值的行。

我试图用单独的宏强制它，但一直不成功。下面的代码适用于整个工作表中的所有行，但是我想针对ie运行它。行2:54。再次反对55：107。并再次...

这里是我到目前为止的代码：

Sub ChkInvAvail() 


'Color any cell GREEN when the number of parts on hand is equal or greater to the corresponding re-order value 
'Color the cell RED when the number of parts on hand is less than the corresponding re-order value 
'Color cell A1 Green if all inventory levels are satisfactory. Color A1 Red if not 
Dim OnHandCol As Long 
Dim ReOrdPntCol As Long 
Dim OnHand, ReOrdPnt, rngOnHand, rngReOrdPnt, AllRedGreenCells, OxmoorGreenCell As Range 
Dim ShoreViewGreenCell, SilasGreenCell, StLouisGreenCell, PhoenixGreenCell, WECGreenCell As Range 
Dim LastRowA, LastRowB, lastRow, DataStartRow As Long 
Dim r, i, j As Long 
Dim i As Long 
Dim j As Long 

    '2 Lines Below Column Address Can Be Changed if Needed 
    Set rngOnHand = ActiveSheet.Range("I:I") 
    Set rngReOrdPnt = ActiveSheet.Range("M:M") 
    '1 Line Below Single Cell Address in Col C Can Be Changed if Needed 
    Set AllRedGreenCells = ActiveSheet.Range("A1") 
    Set OxmoorGreenCells = ActiveSheet.Range("E3") 
    Set ShoreViewGreenCells = ActiveSheet.Range("E4") 
    Set CharlotteGreenCells = ActiveSheet.Range("E5") 
    Set StLouisGreenCells = ActiveSheet.Range("E6") 
    Set PhoenixGreenCells = ActiveSheet.Range("E7") 
    Set WECGreenCells = ActiveSheet.Range("E8") 

    '1 Line Below Row the actual data starts changes 
    DataStartRow = 2 

    LastRowA = MaxRowInXlRange(ActiveSheet, rngOnHand.Address) 
    LastRowB = MaxRowInXlRange(ActiveSheet, rngReOrdPnt.Address) 
    lastRow = Application.Max(LastRowA, LastRowB) 

    OnHandCol = rngOnHand.Column 
    ReOrdPntCol = rngReOrdPnt.Column 

    i = 0 
    j = 0 

    For r = DataStartRow To lastRow 

     Set OnHand = ActiveSheet.Range(Cells(r, OnHandCol), Cells(r, OnHandCol)) 
     Set ReOrdPnt = ActiveSheet.Range(Cells(r, ReOrdPntCol), Cells(r, ReOrdPntCol)) 

     If OnHand.Value >= ReOrdPnt.Value Then 
      OnHand.Interior.Color = RGB(0, 255, 0) 'RGB Code for GREEN 
      'ReOrdPnt.Interior.Color = RGB(0, 255, 0) 'Remove Comment if you want B to Be GREEN too 
     Else 
      If OnHand.Value >= ReOrdPnt.Value * 0.5 And OnHand.Value > 0 Then 
       ReOrdPnt.Interior.Color = RGB(240, 240, 50) 'RGB Code for Yellow 
       'ReOrdPnt.Interior.Color = RGB(0, 255, 0) 'Remove Comment if you want B to Be GREEN too 
       j = j + 1 

      Else 
       ReOrdPnt.Interior.Color = RGB(255, 0, 0) ''RGB Code for RED 
       'OnHand.Interior.Color = RGB(255, 0, 0) 'Remove Comment if you want A to Be RED too 
       i = i + 1 
      End If 
     End If 
    Next 

    If i > 0 Then 
     AllRedGreenCells.Interior.Color = RGB(255, 0, 0) 
    Else 
     If j > 0 Then 
      AllRedGreenCells.Interior.Color = RGB(240, 240, 50) 
      Else 
      AllRedGreenCells.Interior.Color = RGB(0, 255, 0) 
     End If 
    End If 

End Sub 

Function MaxRowInXlRange(xlWsh As Excel.Worksheet, DataRange As String) As Long 
Dim MaxRow As Long 
Dim ColRow As Long 

    'Begin Find Last Row 
    MaxRow = 1 
    ColRow = 1 
    For Each col In xlWsh.Range(DataRange).Columns 
     ColRow = xlWsh.Cells(xlWsh.Rows.Count, col.Column).End(xlUp).Row 
     If ColRow > MaxRow Then 
      MaxRow = ColRow 
     End If 
    Next 
    MaxRowInXlRange = MaxRow 
    'End Find Last Row 

End Function 

Function MaxColInXlRange(xlWsh As Excel.Worksheet, DataRange As String) As Long 
Dim MaxCol As Long 
Dim ColRow As Long 

    'Begin Find Last Row 
    MaxCol = 0 
    ColRow = 1 
    For Each rw In xlWsh.Range(DataRange).Rows 
     ColRow = xlWsh.Cells(rw.Row, xlWsh.Columns.Count).End(xlToLeft).Column 
     If ColRow > MaxCol Then 
      MaxCol = ColRow 
     End If 
    Next 
    MaxColInXlRange = MaxCol 
    'End Find Last Row 

End Function 

情况是我有数据的20列。我在列B中的位置值与列I和O中的比较数据。我已经有宏来做我想要对整个工作表，但要根据列B中的位置值打破我的结果。

我相信有一个简单的方法来做到这一点，但是由于我的想象力有限，我似乎无法弄清楚。

想法？

Answer 1

我遇到了一些麻烦，你试图完成什么，但我正在收集你试图比较一个柱子中的值与另一个柱子中的值吗？

如果是的话我会尝试像

last1 = Range("B" & Rows.Count).End(xlUp).Row 
last2 = Range("I" & Rows.Count).End(xlUp).Row 

For i = 2 to last1   
    For j = 2 to last2 
     'Check if val in 'B' matches val in 'I' 
     If(Range("B" & i).value = Range("I" & j).value) then 
      'If match then colour cell 
      Range("I" & j).Interior.Color = RGB(0, 255, 0) 
     End If 
    next j 
next i