仅循环遍历可见行不起作用

Question

我正在尝试编写一段代码，它将为每个请求只包含一个唯一名称的所有请求着色。为什么仅通过可见单元格循环不起作用？

更新： 如果只有一个名称分配给特定请求，我需要删除行

所以对于以下请求，我想删除 Mary H（因为她的名字在请求中只出现一次）

Request Number  Client Contact Assignee: Full Name
4350257 Eleanor B
4350257 Eleanor B
4350257 Mary H

这个请求可以，不需要删除任何东西

8620428 Kevin M
8620428 Kevin M

在此请求中，我想删除 Mary H 和 Julia K，因为这两个名字在请求中只出现一次）

7208497 Michael W
7208497 Mary H
7208497 Michael W
7208497 Julia K

我的代码：

Sub Testing()

Sheet1.Select

Dim r As Long, LR As Long
Dim ReqNo As Long, CCFullName As Long
Dim rgn2 As Range

LR = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

'Request Number
ReqNo = Application.Match("Request Number", Sheet1.Rows(1), 0)
'Client Contact Assignee: Full Name
CCFullName = Application.Match("Client Contact Assignee: Full Name", Sheet1.Rows(1), 0)

Set rgn2 = Columns(CCFullName)

Dim cl As Range, rng As Range, x As Long

Set rng = Range("A2:A100")
Dim cell As Range

With Range("A2:A100").SpecialCells(xlCellTypeVisible)
   For x = .Rows.Count To 1 Step -1
       Set cell = Range("A" & x) ' this sets the current cell in the loop
            For Each cl In rng.SpecialCells(xlCellTypeVisible)
                For r = LR To 2 Step -1
                    If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1 Then
                        Rows(r).Interior.Color = rgbBlueViolet
                    End If
                Next r
        Next cl
    Next x
End With
End Sub

上面的代码只给整个文档中唯一的名字上色，即 Mary H、Anna W 和 Thomas Y。但是，我需要代码也包含下面的 3 个名字，它们只在特定的文件中出现一次要求。（这只是一个示例）

7208497 Kevin M
7208497 Julia K
8138382 Shahida B

示例数据：

Request Number  Client Contact Assignee: Full Name
4350257 Eleanor B
4350257 Eleanor B
4350257 Mary H
8620428 Kevin M
8620428 Kevin M
7208497 Michael W
7208497 Kevin M
7208497 Michael W
7208497 Julia K
7191212 Thomas Y
7191212 Shahida B
7191212 Shahida B
7191212 Shahida B
8138382 Julia K
8138382 Julia K
8138382 Shahida B
8138382 Julia K
8138382 Anna W

Answer 1

它不适用于可见单元格，因为您是针对 Set rgn2 = Columns(CCFullName) 整列而不是仅针对可见单元格检查计数。

If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1

对于 rgn2 你也应该使用 .SpecialCells(xlCellTypeVisible)。但这对 Columns 不起作用，因此您将不得不使用 Range.

Set rgn2 = Range("B2:B19").SpecialCells(xlCellTypeVisible)

Answer 2

您的代码无法按照您说的去做。我猜了你想要什么，然后为你写了附加代码。它必须粘贴到 Sheet1 工作表的代码模块中。这是一个事件过程，正确的位置很关键。如果粘贴到别处，它将不起作用。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim ReqNo As Long
    Dim Rng As Range
    Dim Cell As Range
    Dim C As Long

    ' skip if more than one cell was selected
    If Target.Cells.CountLarge = 1 Then
        Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))

        If Not Application.Intersect(Target, Rng) Is Nothing Then
            Application.ScreenUpdating = False
            ReqNo = Target.Value
            C = Cells(1, Columns.Count).End(xlToLeft).Column
            With Rng
                Set Rng = .Resize(.Rows.Count, Cells(1, Columns.Count).End(xlToLeft).Column)
            End With
            With Rng.Resize(Rng.Rows.Count, C)
                .Interior.Pattern = xlNone           ' remove existing coloring
                .Font.Color = 0
            End With

            For Each Cell In Rng
                With Cell
                    If .Value = ReqNo Then
                        .Resize(1, C).Interior.Color = rgbBlueViolet
                        .Resize(1, C).Font.Color = xlAutomatic
                    End If
                End With
            Next Cell
            Application.ScreenUpdating = True
        End If
    End If
End Sub

在上面的过程中寻找这一行代码。 Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))。它指定 Request Number 应该在 A 列中。如果您将它移到另一列，您可以在此处更改它。同样，此行指定仅应考虑第 2 行及以下行中的项目。如有必要，您可以在此处更改它。

查找行 C = Cells(1, Columns.Count).End(xlToLeft).Column。它指定第 1 行，即标题行，是您测量 table 宽度的地方。您可以在此处指定另一行。

如果您单击 请求编号，代码就会执行操作。它将用相同的数字紫色为所有行着色。由于选择的背景颜色是深色，因此会将字体颜色更改为白色。

希望这段代码对你有用。

Answer 3

请尝试此代码。它遵循您更新的、更好的需求描述。

Sub DeleteNonDuplicates()

    Dim Rng As Range
    Dim Cnt As Long
    Dim R As Long

    Application.ScreenUpdating = False
    With Sheet1
        R = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, "A"), .Cells(R, "A"))
        For R = R To 2 Step -1
            Cnt = Application.WorksheetFunction.CountIfs(Rng, .Cells(R, "A").Value, _
                                                         Rng.Offset(0, 1), .Cells(R, "B").Value)
            If Cnt = 1 Then
                .Rows(R).EntireRow.Delete
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

要预先测试样品的结果，请在空白栏中输入以下公式并向下复制。

=COUNTIFS($A:$A,$A2,$B:$B,$B2)

代码完全应用此公式，然后删除计数 = 1 的所有行。

仅循环遍历可见行不起作用

Looping through visible rows only not working

excel

vba

loops

nested-loops