Question

所以我有一组包含6组数据的工作表，每组包含6列数据。在六个数据集中的每个数据集中，我只想拉出那些具有匹配集数的数据集。例如，

001 ------ 003 ------ 002 ------ 003 ------ 003 ------ 003 ------
002 ------ 004 ------ 003 ------ 006 ------ 004 ------ 005 ------
003 ------ 005 ------ 006 ------ 007 ------ 009 ------ 013 ------

这是六组数据。在此排序宏中只对每组中的第一列感兴趣。这里，每组共享“003 -----”行。我想写一个宏，删除任何与其他行不匹配的行。有没有一个宏可以解决这个问题，让我只留下003 -----？

我一直在写一个循环宏，说“如果Rng（A1）＆gt; Rng.Offset（，6）AND Rng＆gt; Rng.Offset（，12）......那么（删除相关行）< / p>

然而，为此，我需要涵盖所有可能的可能性。我还缺少另一种更明显的方法吗？

谢谢，

Answer 1

此宏循环遍历Sheet1并输出Output表中的所有相同行。

Sub DeleteNonMatch()
    Dim i As Double
    Dim NotFound As Boolean
    Dim Inp As Worksheet, Out As Worksheet
    Dim r2 As Range, r3 As Range, r4 As Range, r5 As Range, r6 As Range

    'Defines the sheets
    Set Inp = ActiveWorkbook.Sheets("Sheet1") 'Sheet with original dat
    Set Out = ActiveWorkbook.Sheets("Output") 'Output sheet

    'Defines the searchable ranges input sheet
    Set r2 = Inp.Range(Inp.Range("G2").Address & ":" & Inp.Cells(Rows.Count, 7).End(xlUp).Address)
    Set r3 = Inp.Range(Inp.Range("M2").Address & ":" & Inp.Cells(Rows.Count, 13).End(xlUp).Address)
    Set r4 = Inp.Range(Inp.Range("S2").Address & ":" & Inp.Cells(Rows.Count, 19).End(xlUp).Address)
    Set r5 = Inp.Range(Inp.Range("Y2").Address & ":" & Inp.Cells(Rows.Count, 25).End(xlUp).Address)
    Set r6 = Inp.Range(Inp.Range("AE2").Address & ":" & Inp.Cells(Rows.Count, 31).End(xlUp).Address)

    'Sets headers in output sheet
    With Out.Range("A1")
        .Offset(0, 0).Value = Inp.Range("A1").Value
        .Offset(0, 1).Value = Inp.Range("G1").Value
        .Offset(0, 2).Value = Inp.Range("M1").Value
        .Offset(0, 3).Value = Inp.Range("S1").Value
        .Offset(0, 4).Value = Inp.Range("Y1").Value
        .Offset(0, 5).Value = Inp.Range("AE1").Value
    End With

    'Prints identical groups to output sheet
    For i = 2 To Inp.Cells(Rows.Count, 1).End(xlUp).Row Step 1
        NotFound = False

        If r2.Find(Inp.Cells(i, 1).Value, , , xlWhole) Is Nothing Then NotFound = True
        If r3.Find(Inp.Cells(i, 1).Value, , , xlWhole) Is Nothing Then NotFound = True
        If r4.Find(Inp.Cells(i, 1).Value, , , xlWhole) Is Nothing Then NotFound = True
        If r5.Find(Inp.Cells(i, 1).Value, , , xlWhole) Is Nothing Then NotFound = True
        If r6.Find(Inp.Cells(i, 1).Value, , , xlWhole) Is Nothing Then NotFound = True

        If NotFound = False Then
            With Out.Cells(Out.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
                .Offset(0, 0).Value = Inp.Cells(i, 1).Value
                .Offset(0, 1).Value = Inp.Cells(i, 1).Value
                .Offset(0, 2).Value = Inp.Cells(i, 1).Value
                .Offset(0, 3).Value = Inp.Cells(i, 1).Value
                .Offset(0, 4).Value = Inp.Cells(i, 1).Value
                .Offset(0, 5).Value = Inp.Cells(i, 1).Value
            End With
        End If
    Next i
End Sub

我想在Excel上执行一个简单的任务，但VBA代码变得非常非常长

1 个答案: