Question

我想要做的是创建一个宏来查看列（AF）并根据该值，将列（BI），（BJ）和/或（BK）比较在一起，如果它为false，则突出显示比较黄色细胞。我知道这有点难以理解，但这个例子应该有助于澄清：

我的工作表包含以下列：

Column AF    Column BI    Column BJ    Column BK
PRODUCT      Height       Length       Width

我需要一个宏来查看产品类型并比较该产品的尺寸，如下所示：

  - If product = A, then Length = Width, if not then highlight Length and Width Cells
  - If product = B then Length > Width, if not then highlight Length and Width Cells
  - If product = C then Width > Height < Length, if not highlight Length, Width, and Height cells
  - If product - D then Width = Length < Height, if not highlight Width, Length, and/or Height

我的数据从第3行开始，到第5002行结束。

我已经尝试过对此进行研究，并且只能找到比较两个单元格然后编写第三列的解决方案。我可以结合使用IF公式和条件格式来实现这一目标，但我不希望一直运行，因为工作表将被排序和颜色编码。我打算将这个宏放入一个命令按钮。

Answer 1

建议合并Statements，例如Select Case，If...Then...Else，以及操作员And，Or。请参阅以下页面：

https://msdn.microsoft.com/en-us/library/office/gg251599.aspx

https://msdn.microsoft.com/en-us/library/office/gg278665.aspx

https://msdn.microsoft.com/EN-US/library/office/gg251356.aspx

之后你应该能够写出类似于此的东西： （以下代码仅为示例，不起作用）

Select Case Product
Case A
    If Length <> Width Then
        Rem Highlight Length And Width  Cells
    End If
Case B
    If Length <= Width Then
        Rem Insert here the code to highlight Length And Width Cells
    End If
Case C
    If Width <= Height And Height >= Length Then
        Rem Insert here the code to highlight Length, Width, and Height cells
    End If
Case D
    If Width <> Length And Length >= Height Then
        Rem Insert here the code to highlight Width, Length, and/or Height
    End If
End Sub

如果您不知道突出显示宽度，长度和高度单元格;我建议在录制宏时手动完成，这应该是一个很好的起点。

Answer 2

我建议使用对象，为数据范围定义变量，验证每一行，验证字段的位置等。请参阅下面带注释的代码

Sub Highlight_Cells_based_Comparison()
Dim rData As Range
Dim rRow As Range
Dim rCllsUnion As Range
Rem Set variables to hold Fields position within the DATA range
Dim bPosProd As Byte, bPosHght As Byte, bPosLeng As Byte, bPosWdth As Byte
Rem Set variables to hold Fields values
Rem (data type Variant as don't know type of values these fields are holding, change as appropriated)
Rem see https://msdn.microsoft.com/en-us/library/office/gg251528.aspx)
Dim sProd As String, vHght As Variant, vLeng As Variant, vWdth As Variant
Dim lRow As Long

    Rem Set Range (assuming it goes from column C to BK - change as needed)
    Rem Not starting from column A on porpuse
    Set rData = ActiveSheet.Range("C3:BK5002")

    Rem Get Fields position from Header row
    Rem Suggest to use this method instead of hard coding columns
    On Error Resume Next
    With rData
        bPosProd = WorksheetFunction.Match("PRODUCT", .Rows(1), 0)
        bPosHght = WorksheetFunction.Match("Height", .Rows(1), 0)
        bPosLeng = WorksheetFunction.Match("Length", .Rows(1), 0)
        bPosWdth = WorksheetFunction.Match("Width", .Rows(1), 0)
    End With
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0

    Rem Loop thru each row excluding header           
    For lRow = 2 To rData.Rows.Count
            Set rRow = rData.Rows(lRow)
            With rRow
                Rem Get Row Field values
                sProd = .Cells(bPosProd).Value2
                vHght = .Cells(bPosHght).Value2
                vLeng = .Cells(bPosLeng).Value2
                vWdth = .Cells(bPosWdth).Value2                    

            Select Case sProd
            Case A 'Change value of A as required
            Rem If product = A, then Length = Width, if not then highlight Length and Width Cells
            Rem If Length <> Width Then Highlight Length And Width  'Cells
                If vLeng <> vWdth Then
                    Set rCllsUnion = Union(.Cells(bPosLeng), .Cells(bPosWdth))
                    Rem Suggest to use a subroutine for this piece as it's a repetitive task
                    Rem see https://msdn.microsoft.com/en-us/library/office/gg251648.aspx
                    GoSub CllsUnion_Highlight
                End If

            Case B
                Rem repeat as in Case A with required changes
            Case C
                '...
            Case D
                '...
    End Select: End With: Next


Exit Sub
Rem Subroutine to highlight cells
CllsUnion_Highlight:
    With rCllsUnion.Interior
        .Color = 65535
        .TintAndShade = 0
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .PatternTintAndShade = 0
    End With
    Return

End Sub

根据第三列值的值比较两列

2 个答案: