Question

我花了几个小时研究这段代码，并且如实地需要一些更好的专家意见。

Sheet 1上的A列具有动态数据列表，通常是IP地址，但为此它只是一个数字。可能有重复或不重复。

我需要在A列中找到所有相同的数据，选择它，然后为它运行特定的代码，然后为A中的每组相同数据运行相同的代码。我的代码是在C列中找到与之匹配的值小于4的标准，或<4。 C列只有1到5的值。目标是针对A中的每组相同数据，然后查看C并选择C中任何仅为1,2或3的值，而不是4或如果为真，则将整行复制到另一张表。

我的代码很有用，但速度很慢，如果没有要复制的数据则无法解释。

现在我使用名为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）
- 如果有任何行可见，请将它们复制到第2页的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

Sheet1和Sheet2

修改

有三种方式可以参考表格：

工作表名称（或选项卡名称） - 用户在选项卡（左下角）中可见的名称

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

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

参考表格：

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

另一个区别是Sheets()集合和Worksheets()集合：

表格集合不仅包括工作表的集合，还包括其他类型的表格，包括图表表单（...）

（more details from Microsoft）

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

1 个答案: