vba - 在 Column 中查找相同的数据并将其过滤到另一个工作表

Question

我在这段代码上花了几个小时，并且确实需要一些更好的专家意见。

表 1 上的 A 列有动态数据列表，通常是 IP 地址，但它只是一个数字。可以有重复，也可以没有。

我需要在 A 列中找到所有相同的数据，选择它，并为其运行特定代码，然后为 A 中的每组相同数据运行相同的代码。我的代码是在 C 列中查找符合 Less 标准的值大于 4，或 <4。 C 列的值只有 1 到 5。目标是针对 A 中的每组相同数据，然后查看 C 并选择 C ​​中只有 1、2 或 3，而不是 4 或 5 的任何值，并在为真时将整行复制到另一张纸上.

我的代码可以工作，有点，但速度很慢，并且不考虑是否没有要复制的数据。

现在，我使用名为 Test 的工作表从 A 中查找唯一数据，然后将 A 中的相同数据复制到名为 mm 的工作表中，过滤数据，然后仅将过滤后的数据复制到工作表数据。每次循环都会删除 M 中的内容，并在代码末尾删除 Test。

请帮我清理它并使其更快。如果您想查看示例数据，请在下方提供图片链接。

归功于 christodorov 让我开始使用他的基本代码。

Dim currentCell As Long
Dim numOfValues As Long

Sub filterNextResult()

' copy and move the data from the data sheet, column A (can be changed if needed) to a new sheet called "temp"


' check to make sure there is at least 1 data point in column A on the temp sheet
If currentCell = 0 Then
Application.ScreenUpdating = False
Call createNewTemp
Application.ScreenUpdating = True
End If

' find the total number of unique data points we will be filtering by in column A of the temp sheet
If numOfAccounts = 0 Then
Application.ScreenUpdating = False
Call findNumOfValues
Application.ScreenUpdating = True
End If

Dim X As Integer
Dim lr As Long
Dim lrdata As Long
Dim Lastmm As Integer
lr = Sheets("mm").Cells(Rows.Count, "A").End(xlUp).Row + 1
lrdata = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
currentCell = 2
numOfValues = 21
'MsgBox (currentCell)

On Error Resume Next
For X = 1 To numOfValues
        With Sheet1.UsedRange
            .AutoFilter 1, Worksheets("temp").Range("A" & currentCell).Value
            Set filRange = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
                If Not IsEmpty(filRange) Then
                filRange.EntireRow.Copy Destination:=Sheets("mm").Range("A" & lr)
                Worksheets("mm").Activate
                Range("A1").Select
'                Range("A1" & .Cells(Rows.Count, 1).End(xlUp).Row).Select
                    With Range("A1")
'                        .AutoFilter
                        .AutoFilter Field:=3, Criteria1:="<4"
                            Lastmm = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
                            Range("A2:C" & Lastmm).Select
                            Selection.Copy
                            Worksheets("data").Activate
                            Range("A" & lrdata).PasteSpecial Paste:=xlPasteValues
                            Application.CutCopyMode = False
                            lrdata = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
                            Worksheets("mm").Activate
                            Range("A1").Select
                            Worksheets("mm").AutoFilterMode = False
                            Lastmm = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
                            Range("A2:C" & Lastmm).Select
                            Selection.Delete shift:=xlToLeft

                    End With
                'Range("A1" & .Cells(Rows.Count, 1).End(xlUp).Row).Select
                'With Selection
'                lr = Sheets("mm").Cells(Rows.Count, "A").End(xlUp).Row + 1
                End If
            currentCell = currentCell + 1
        '    MsgBox (currentCell)
        '    MsgBox (numOfValues)
'            .AutoFilter
        End With

Next X


Application.DisplayAlerts = False
Worksheets("temp").Delete
Application.DisplayAlerts = True

End Sub

'sub that will look for the number of values on the temp sheet column a
Private Sub findNumOfValues()
' count the number of non empty cells and assign that value (less 1 for the title in our case) to the numOfValues
numOfValues = Worksheets("temp").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
'    MsgBox (numOfValues)
End Sub

Private Sub createNewTemp()

Sheet1.Range("A:C").Copy
'ActiveWorkbook.Sheets.Add.Name = "temp"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "temp"

' remove duplicates
Worksheets("temp").Range("A1").Select
With ActiveWorkbook.ActiveSheet
    .Paste
    .Range("A:C").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With

' check to make sure there are vlaues in the temp sheet
If Worksheets("temp").Range("A2").Value = "" Then
    MsgBox "There are no filter values"
    End
Else
    currentCell = 2
End If

'MsgBox (currentCell)

Sheet1.Activate
Sheet1.Range("A1").Select
Selection.AutoFilter

End Sub

Example spreadsheet looks like this

Answer 1

这将通过以下步骤遍历 A 列 Sheet1 中的每个唯一值

过滤器 col A

将第二个过滤器应用于 C 列 (< 4)

如果任何行可见，则将它们复制到 Sheet2

的 Col A 中的第一个空单元格

Option Explicit

Public Sub FindIdenticalInALessThan4InC()
    Const COL_A = 1
    Const COL_C = 3
    Const LESS_THAN_4 = "<4"
    Dim ws1 As Worksheet, ws2 As Worksheet, lrWs1 As Long, lrWs2 As Long
    Dim arrA As Variant, d As Object, i As Long, unique As Variant, maxRows As Long

    Set ws1 = Sheet1:  Set ws2 = Sheet2                 'ws2 = CodeName for Sheets("mm")
    maxRows = Rows.Count
    If ws1.AutoFilterMode Then ws1.UsedRange.AutoFilter 'clear filters
    lrWs1 = ws1.Cells(maxRows, "A").End(xlUp).Row + 1
    lrWs2 = ws2.Cells(maxRows, "A").End(xlUp).Row + 1
    If lrWs1 > 1 Then                                   'expects first row as headers
        Set d = CreateObject("Scripting.Dictionary")
        arrA = ws1.Range(ws1.Cells(1, COL_A), ws1.Cells(lrWs1, COL_A))
        For i = 2 To lrWs1
            d(arrA(i, 1)) = vbNullString                'get uniques from col A
        Next
        Application.ScreenUpdating = False
        For Each unique In d
            With ws1.UsedRange
                .AutoFilter Field:=COL_A, Criteria1:=unique
                .AutoFilter Field:=COL_C, Criteria1:=LESS_THAN_4, Operator:=xlAnd
                If .Columns(1).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                    .Offset(1).Resize(lrWs1 - 2, .Columns.Count).Copy ws2.Cells(lrWs2, "A")
                    lrWs2 = ws2.Cells(maxRows, "A").End(xlUp).Row + 1
                End If
                .AutoFilter
            End With
        Next
        Application.ScreenUpdating = True
    End If
End Sub

工作表 1 和工作表 2



编辑:

有 3 种方式来引用工作表:

工作表名称(或选项卡名称)- 用户在选项卡中可见的名称(左下方)

工作表索引(或选项卡索引)- 显示给用户的选项卡顺序(左下)

CodeName - 这是仅在 VBA 编辑器中可见的工作表名称(左上角)

在下面的代码中，我们指的是同一张表:

Public Sub SheetNames()
    Dim ws2 As Worksheet

    ws2 = Sheets("Sheet2")    'Tab Name
    ws2 = Sheets(2)           'Tab Index
    ws2 = Sheet2              'CodeName (visible only in the VBA editor)
End Sub

引用单子(monad):



CodeName 在 VBA 中更可靠，因为普通用户不会编辑它(不太可能更改)

另一个需要区分的是 Sheets()集合和 Worksheets()收藏:

The Sheets collection consist of not only a collection of worksheets but also other types of sheets to include Chart sheets (...)

( more details from Microsoft)