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

我试图创build一个这样做的macros：检查从一个小列表中的值（我已经使用了一个数组）去工作表中，并为每一行包含数组的值复制整个行在另一个工作表。 我混合了其他macros来创build一个，但我有一个问题，macros检查数组上的值，并复制工作表中的所有行，但每次它不复制find的第一行：ex，如果行包含“abl”分别是：100,200和300，macros只是复制200和300忽略100.这是我的macros

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 (ie "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作为标题1，即要过滤的实际数据从行2开始向下

这也将这个值从单元格A1向下粘贴到目标工作表中，没有空行。 如果原始行序列受到尊重，则可以完成