Question

我一直在研究VBA脚本一段时间，它会遍历列的值并删除所有行，其值只出现一次（几乎与删除重复项相反）。

Column Headers to make explanation easier

“VTR”列中的数字不止一次出现。大多数只出现一次。我希望宏删除所有行，其中“VTR”列中的数字只出现一次。（如果其中一个数字出现多次，则差异在于'AFTARTKRZ'列，其中值可以要么是（GAPNK或GAPN2），要么是RSLNV或RSVNK。（GAPNK或GAPN2都是一样的）

即AFTARTKRZ

一行一次

（GAPNK或GAPN2）

- 或两次

（GAPNKorGAPN2），RSLNV 或（GAPNKorGAPN2），RSVNK

或三次 （GAPNK或GAPN2），RSLNV，RSVNK。

我想删除所有只出现一次的内容（GAPNKorGAPN2）

此外，我想在最后将重复项的'AFTARTKRZ'值添加到2个额外列。即，当（GAPNK或GAPN2）出现两次或三次时，我想在结尾的最后两列输入'AFTARTKRZ'列值。

这样的事情应该是最终的结果


VTR|AFTARTKRZ | Add1     | Add2
11 |GAPNK     |RSLNV     | RSVNK|  - VTR appeared thrice
12 |GAPN2     |RSLNV     |      |  - Appeared twice as (GAPNKorGAPN2), RSLNV 
13 |GAPNK     |RSVNK     |      |  - Appeared twice as (GAPNKorGAPN2), RSVNK
14 |GAPN2     |          | 
15 |GAPNK     |          | 
16 |GAPN2     |          |

相关部分从'~~~~在A上工作

开始

Sub Test()
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim RowsToTestC As Range, Delrange As Range
    Dim i As Long, Lrow As Long, Lop As Long

    Set ws1 = ThisWorkbook.Worksheets(1)    
    ThisWorkbook.ActiveSheet.Name = "A"

    ws1.Copy ThisWorkbook.Sheets(Sheets.Count)    
    ThisWorkbook.ActiveSheet.Name = "B"

    Set ws2 = ThisWorkbook.Worksheets(2)    
    ws1.Copy ThisWorkbook.Sheets(Sheets.Count)

    ThisWorkbook.ActiveSheet.Name = "C"    
    Set ws2 = ThisWorkbook.Worksheets(3)

    '~~~~ Work on C    
    Worksheets("C").Activate
    With ActiveSheet
        ActiveSheet.Range("A:AQ").RemoveDuplicates Columns:=6, Header:=xlNo
    End With

    Worksheets("C").Activate    
    Application.ScreenUpdating = False

    '~~> Delete all but RSV
    For Lrow = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("D" & Lrow).Value = "GAPNK" Or Range("D" & Lrow) = "GAPN2" Then
            Rows(Lrow).EntireRow.Delete
        End If
    Next Lrow

    '~~~~ Work on B
     Worksheets("B").Activate      
     With ActiveSheet
        ActiveSheet.Range("A:AQ").RemoveDuplicates Columns:=6, Header:=xlNo
    End With

    Worksheets("B").Activate

    Application.ScreenUpdating = False

    '~~> Delete all but GAP
    For Lrow = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("D" & Lrow).Value = "RSVNK" Or Range("D" & Lrow) = "RSLNV" Then
            Rows(Lrow).EntireRow.Delete
        End If
    Next Lrow        

     '~~~~ Work on A
     Worksheets("A").Activate

     Range("AR1").Select
     ActiveCell.FormulaR1C1 = "RSVNK"
     Range("AS1").Select
     ActiveCell.FormulaR1C1 = "RSLNV"        

     With ws1
        '~~> Get the last row which has data in Col A
        Lop = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Loop through the rows
        For i = 2 To Lop
            '~~> For for multiple occurances
            If .Cells(i, 6).Value <> "" And .Cells(i, 4).Value <> "" Then
                If Application.WorksheetFunction.CountIf(.Columns(6), .Cells(i, 6)) = 1 And _
                Application.WorksheetFunction.CountIf(.Columns(4), .Cells(i, 4)) = 1 Then
                    '~~> Store thee row in a temp range
                    If Delrange Is Nothing Then
                        Set Delrange = .Rows(i)
                    Else
                        Set Delrange = Union(Delrange, .Rows(i))
                    End If
                End If
            End If
        Next
    End With
End Sub

Answer 1

您的代码逻辑无效。

条件If Application.WorksheetFunction.CountIf(.Columns(4), .Cells(i, 4)) = 1始终为False，因为这是包含AFTARTKRZ键的列。我不知道你有多少行数据，但即使在你给我们的10行样本中，结果总是大于1。

我确实认为你这使得这种不必要的复杂化。您只想尝试填充两个列表：一个是GAP而另一个是RSV？然后，您想要创建第三个列表，其中GAP条目具有相应的RSV条目？

这可以在几个简短的例程中完成。您可以取消所有工作表复印和行删除操作，只需将三个列表直接写入工作表即可。

下面的代码向您展示了如何做到这一点。我创建了4张，因此您可能需要在工作簿中添加另一张：Sheet1是您的摘要列表（A），Sheet2是您的GAP列表（B），{{1}是你的RSV列表（C），Sheet3保存原始数据。

希望这段代码可以帮助您入门：

Sheet4

VBA-如果值不是重复，则删除行并保留所有具有重复值的行

1 个答案: