Question

我正在尝试建立一个宏来运行Application.Match以将一个单元格（A列）与P列中的一个单元格匹配移动到中间的H列。它逐月比较项目，所以我需要查看是否已取消或发生任何新项目。但是，如果不匹配，请将其移至列表底部或突出显示，以便我手动进行移动。对Excel VBA来说是非常新的，因此非常感谢您的帮助！

我从该论坛找到了大部分代码：Compare column A with column C, Move matching Cell from location to column B on corresponding row

感谢@Samatar。

Sub Sorter()

Dim rng1 As Range, rng2 As Range, rng3 As Range, i As Long, iL As Long, var As Variant

iL = Sheets("Comparison").Range("P" & Rows.Count).End(xlUp).Row
For i = 2 To iL
     Set rng1 = Sheets("Comparison").Range("P" & i)
     Set rng2 = Sheets("Comparison").Range("A:A")
     Set rng3 = Sheets("Comparison").Range("H:H")

     var = Application.Match(rng1.Value, rng2, 1)

     If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then
          bln = True
          If bln = True Then
                 rng1.Copy
                 rng1.Offset(0, -8).PasteSpecial
                 var2 = Application.Match(rng2.Value2, rng3, 1)
                 If Not IsError(Application.Match(rng2.Value2, rng3, 0)) Then
                    bln = False
                    If bln = False Then
                        rng2.Interior.Color = RBG(255, 255, 0)
                    End If
                 End If

                Set rng1 = Nothing
                Set rng2 = Nothing
                Set rng3 = Nothing
           End If
      End If

 Next i

End Sub

Answer 1

我通过少量重构您的数据结构进行了测试，但是您可能只使用单个COUNTIF而不是多个MATCH函数，因为您要做的只是看（如果存在）而不是对MATCH的实际位置做任何事情。

Sub Sorter()

Dim iL As Long
Dim i As Long

    With Sheets("Comparison")

        iL = .Range("A" & Rows.Count).End(xlUp).Row

        For i = 2 To iL
            If WorksheetFunction.CountIf(.Range("P:P"), .Range("A" & i)) = 0 Then
                .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1) = .Range("A" & i)
                .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Interior.Color = RGB(255,255,0)
            Else
                .Range("H" & i) = .Range("A" & i)
            End If
            .Range("A" & i) = ""
        Next i
        .Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp '<- added these for formatting purposes, they can be deleted if you don't want them
        .Range("H:H").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp '<- added these for formatting purposes, they can be deleted if you don't want them

    End With

End Sub

移动匹配的单元格时，如果找不到匹配项，则使用Match为单元格着色

1 个答案: