Question

我正在尝试创建一个执行此操作的宏：检查小列表中的值（我使用过数组）转到工作表中，对于包含数组值之一的每一行，复制另一个工作表中的整行。我已经混合了其他宏来创建一个但是我遇到了一个问题，宏检查数组上的值并复制我工作表中的所有行但是每次它都没有复制找到的第一行：ex，如果包含的行“abl”是：100,200和300，宏只复制200和300忽略100。这是我的宏

Sub Test_339_1()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim nam(1 To 7) As String, cel As Range, rng As Range
        i = 1
        Set rng = Worksheets("Ctr 339").Range("V4:V10")
        For Each cel In rng
            nam(i) = cel.Value
            i = i + 1
        Next cel
        For i = 1 To 7
            For Each cell In Sheets("FB03").Range("E:E")
                If cell.Value = nam(i) Then
                    matchRow = cell.Row
                    Rows(matchRow & ":" & matchRow).Copy
                    Sheets("Test_macro").Select
                    ActiveSheet.Rows(matchRow).Select
                    ActiveSheet.Paste
                    Sheets("FB03").Select
                End If
            Next
            Sheets("Test_macro").Select
        Next i
        Sheets("Test_macro").Select
        On Error Resume Next
        Range("A1:A50000").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Answer 1

试试这个重构的代码：

Sub Test_339_1()
Dim nam(1 To 7) As String, cel As Range, lastrow As Long
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    nam = Worksheets("Ctr 339").Range("V4:V10").Value
    lastrow = Sheets("FB03").Cells(Sheets("FB03").Rows.Count, "E").End(xlUp).Row
    For Each cell In Sheets("FB03").Range("E1:E" & lastrow)
        For i = 1 To 7
            If cell.Value = nam(i) Then
                matchRow = cell.Row
                Sheets("FB03").Rows(matchRow).Copy Sheets("Test_macro").Rows(Sheets("Test_macro").Cells(Sheets("Test_macro").Rows.Count, "E").End(xlUp).Row + 1)
                Exit For
            End If
        Next i
    Next cell
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub

它应该更快，它不会循环超过700万次。

Answer 2

AutoFilter()应该加快速度：

Option Explicit

Sub Test_339_1()
    Dim nam As Variant

    nam = Application.Transpose(Worksheets("Ctr 339").Range("V4:V10").Value)
    With Sheets("FB03")
        With .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
            .AutoFilter Field:=1, Criteria1:=nam, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (i.e. "State") with 1
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filterd cells other than header
                With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
                    .EntireRow.Copy Sheets("Test_macro").Cells(.Cells(1, 1).Row,1)
                End With
            End If
        End With
        .AutoFilterMode = False
    End With
End Sub

你只需要第1行作为标题，即要过滤的实际数据从第2行开始向下

这也会从单元格A1向下粘贴目标工作表中的值而没有空白行。如果原始行序列得到遵守，可以完成

如果单元格包含特定文本，则复制整行

2 个答案: