Excel宏不起作用

Question

我正在尝试编写一个可以过滤列E和F的宏。如果满足两个条件，则会将整行复制到新工作表。

这是我到目前为止所做的，但我无法让它发挥作用......

Sub carving()

    '482
    SearchForString "482", "A01"
    SearchForString "482", "A02"
    SearchForString "482", "A03"
    SearchForString "482", "A04"


    '483
    SearchForString "483", "A01"
    SearchForString "483", "A02"
    SearchForString "483", "A03"
    SearchForString "483", "A04"

    '484
    SearchForString "484", "A01"
    SearchForString "484", "A02"
    SearchForString "484", "A03"
    SearchForString "484", "A04"


    '485
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

    '482E
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

    '482F
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

End Sub

Sub SearchForString(ColE, ColF)

    'Dim LSearchRow As Long
    Dim shtSearch As Worksheet
    Dim shtCopyTo As Worksheet
    Dim rw As Range

    'LSearchRow = 2 'Start search in row 2

    Set shtSearch = Sheets("example")
    Set shtCopyTo = Sheets("test")

    Dim LSearchRow As Integer
    For LSearchRow = 2 To 30000
        If Len(shtSearch.Cells(LSearchRow, 1).Value) > 0 Then
            Set rw = shtSearch.Rows(LSearchRow)
            If rw.Cells(7).Value = ColE And rw.Cells(6).Value = ColF Then                                          
                rw.Copy shtCopyTo.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                'Exit Do '? you say there's only one result to find
            End If
        End If
    Next LSearchRow

End Sub

任何帮助将不胜感激。

Answer 1

这可能会成功。

Sub MultiFilterAndCopy()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim LastRow As Long
Dim PasteTo As Range

With Sheets("example").Range("E1:F1")
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:=Array( _
        "482", "483", "484", "485"), Operator:=xlFilterValues
    .AutoFilter Field:=2, Criteria1:=Array( _
        "A01", "A02", "A03", "A04"), Operator:=xlFilterValues
End With



LastRow = Range("E1048576").End(xlUp).Row
Set PasteTo = Sheets("test").Range("A1048576").End(xlUp).Offset(1, 0)
Range("2:" & LastRow).Copy PasteTo

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

如果您从下面开始使用数据：

然后只运行宏的过滤器部分，示例表将如下所示：

然后当完成所有工作后，您的Test表将如下：

如果您完成后希望example工作表返回其原始状态，并显示所有行，请使用以下修改过的宏：

Sub MultiFilterAndCopy()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim LastRow As Long
Dim PasteTo As Range

With Sheets("example").Range("E1:F1")
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:=Array( _
        "482", "483", "484", "485"), Operator:=xlFilterValues
    .AutoFilter Field:=2, Criteria1:=Array( _
        "A01", "A02", "A03", "A04"), Operator:=xlFilterValues
End With



LastRow = Range("E1048576").End(xlUp).Row
Set PasteTo = Sheets("test").Range("A1048576").End(xlUp).Offset(1, 0)
Range("2:" & LastRow).Copy PasteTo

Sheets("example").Range("E1:F1").AutoFilter

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Answer 2

尝试以下代码：

它使用范围的Find方法，而不是通过每行循环，从而获得良好的性能。它还复制了所有有价值的事件。

您可以参考 link

Dim i As Integer

Sub carving()
    i = 1
'482
    SearchForString "482", "A01"
    SearchForString "482", "A02"
    SearchForString "482", "A03"
    SearchForString "482", "A04"


    '483
    SearchForString "483", "A01"
    SearchForString "483", "A02"
    SearchForString "483", "A03"
    SearchForString "483", "A04"

    '484
    SearchForString "484", "A01"
    SearchForString "484", "A02"
    SearchForString "484", "A03"
    SearchForString "484", "A04"


    '485
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

    '482E
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

    '482F
    SearchForString "485", "A01"
    SearchForString "485", "A02"
    SearchForString "485", "A03"
    SearchForString "485", "A04"

End Sub

Sub SearchForString(ColE, ColF)

'Dim LSearchRow As Long
    Dim shtSearch As Worksheet, shtCopyTo As Worksheet
    Dim rw As Range, rngColE As Range, rngColF As Range
    Dim lastRow As Long, searchRngColE As Range
    Dim firstCell As String


    'LSearchRow = 2 'Start search in row 2

    Set shtSearch = Sheets("example")
    Set shtCopyTo = Sheets("test")

    lastRow = shtSearch.Range("A" & Rows.Count).End(xlUp).Row
    If lastRow < 2 Then lastRow = 2

    Set searchRngColE = shtSearch.Range("E1:E" & lastRow)

    Set rngColE = searchRngColE.Find(What:=ColE, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)

    If Not rngColE Is Nothing Then firstCell = rngColE.Address


    Do While Not rngColE Is Nothing

        If rngColE.Offset(0, 1) = ColF Then
            rngColE.EntireRow.Copy shtCopyTo.Cells(i, 1)
              i = i + 1
        End If


        Set rngColE = searchRngColE.FindNext(rngColE)

        If Not rngColE Is Nothing Then
            If rngColE.Address = firstCell Then Exit Do
        End If

    Loop

End Sub