使用excel vba删除基于部分中符合特定条件的一个条目的数据部分

Question

我有一个excel工作表（比如工作表A），里面有数据，被组织成由空行分隔的分组，并由N列中的一个公共条目分组。在每个分组中，我需要检查不同工作簿中的另一个excel表（比如说工作表B），看看工作表A列中的任何条目是否与工作表B列C中的任何条目的条目相匹配。如果在第一张纸的单个分组中，任何C列条目与A列条目相匹配，我不对该分组做任何操作。如果没有匹配项，我需要删除整个分组。以下是我的尝试，但我大多对1感到困惑。如何删除一个分组和2。如何正确调用每个表/列。

Sub DeleteAdjacent()
    Dim wb1 As Workbook, Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
    Dim lastrow1 As Long, Dim lastrow2 As Long, Dim i As Long, Dim j As Long
    Set wb1 = Workbooks("Workbook1.xlsx")
    Set wb2 = Workbooks("Workbook2.xlsx")
    Set sh2 = wb2.Sheets(“Sheet B”)
    Set sh1 = wb1.Sheets("Sheet A")
    lastrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    lastrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
    For j = lastrow1 To 1 Step -1
        cell = "N" & j
        cell1 = "N" & (j - 1)
        Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
            For i = lastrow2 To 1 Step -1
                cell2 = "C" & i
                cell3 = "A" & j
                If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
                    Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
                        sh1.Range(j, cell).EntireRow.Delete
                    Loop
                End If
            Next i
        Loop
    Next j
End Sub

编辑：仔细观察我的尝试，它实际上会与我想做的相反。当有比赛时，我试图删除整个分组，而我实际上想要完全相反的结果。我认为下面的部分应该改一下。

If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
    Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
        sh1.Range.Cells(j, cell).EntireRow.Delete
    Loop
End If

我试图纠正这一点可能太简单了？

If sh1.Cells(j, cell3).Value <> sh2.Cells(i, cell2).Value Then
    Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
        sh1.Range.Cells(j, cell).EntireRow.Delete
    Loop
End If

Answer 1

我想如果我要解决这个问题，我不会将A与C进行比较，也不会在同一过程中进行组循环检查。如果你先创建一个价值观到群体的映射，你可能会更容易理解这个问题。假设值为10的值存在于第1、3和5组中，那么你可以只检查10，然后立即从未来的检查中删除3组。Collections的Collection对此非常有用，因为key的查找速度非常快，而且您不必担心它存储的项目数量。

如果每个组都有一个Ranges集合，那么这将是一个简单的过程，可以消除匹配的组，然后在一次命中中删除所有剩余的Ranges。

下面的代码应该为您做到这一点（但与任何行删除代码一样，我建议您首先备份原始数据！）：

Public Sub DeleteAdjacent()
    Dim ws As Worksheet
    Dim valueGroupMap As Collection
    Dim groupRanges As Collection
    Dim values As Collection
    Dim lastRow As Long
    Dim groupRng As Range
    Dim valueCell As Range
    Dim groupCell As Range
    Dim rng As Range
    Dim v As Variant
    Dim r As Long
    'Read the Column A worksheet
    Set ws = Workbooks("Workbook1.xlsx").Worksheets("Sheet A")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '+1 to get a blank row at end
    'Define the value map group ranges
    Set valueGroupMap = New Collection
    Set groupRanges = New Collection
    Set groupRng = ws.Cells(1, "N")
    For r = 1 To lastRow
        Set valueCell = ws.Cells(r, "A")
        Set groupCell = ws.Cells(r, "N")
        If Len(CStr(groupCell.Value2)) = 0 Then
            'We've reached the end of a group
            Set rng = ws.Range(groupRng, groupCell.Offset(-1))
            groupRanges.Add rng, CStr(groupRng.Value2)
            Set groupRng = Nothing
        Else
            'We're working within a group
            If groupRng Is Nothing Then
                Set groupRng = groupCell
            End If
            'Create the value to group map
            Set values = Nothing
            On Error Resume Next
            Set values = valueGroupMap(CStr(valueCell.Value2))
            On Error GoTo 0
            If values Is Nothing Then
                Set values = New Collection
                valueGroupMap.Add values, CStr(valueCell.Value2)
            End If
            values.Add CStr(groupRng.Value2)
        End If
    Next

    'Read the Column C worksheet
    Set ws = Workbooks("Workbook2.xlsx").Worksheets("Sheet B")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    On Error Resume Next
    For r = 1 To lastRow
        'Check if we have the value
        Set values = Nothing
        Set values = valueGroupMap(CStr(ws.Cells(r, "C").Value2))
        If Not values Is Nothing Then
            'We do, so remove the group ranges from our list
            For Each v In values
                groupRanges.Remove CStr(v)
            Next
        End If
    Next
    On Error GoTo 0
    'Create a range of the groups still remaining in the list
    Set rng = Nothing
    For Each groupRng In groupRanges
        If rng Is Nothing Then
            Set rng = groupRng
        Else
            Set rng = Union(rng, groupRng)
        End If
    Next
    'Delete that range
    rng.EntireRow.Delete
End Sub