0

我正在尝试编写一个宏来过滤列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

任何帮助，将不胜感激。

4

2 回答 2

0

这可能会奏效。

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
于 2013-05-16T18:58:04.410 回答
-1

试试下面的代码：

它使用Find范围的方法而不是循环遍历每一行，从而获得良好的性能。它还复制所有出现的价值。

你可以参考这个链接

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
于 2013-05-16T19:13:13.617 回答