I'm trying to create a macro that does this: Check the values from a small list (I've used an array) Go in a worksheet and for every row that contains one of the values of the array copy the entire row in another worksheet. I've mixed other macros to create one but I got one problem, the macro check the value on the array and copies all the rows in my worksheet but every time it doesn't copy the first row found: ex, if row that contain "abl" are: 100,200 and 300, the macro just copy 200 and 300 ignoring 100. This is my macro
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
Try this refactored code:
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
It should be quicker, It will not loop over 7 million times.
AutoFilter()
should speed things up quite a bit:
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
you only need row 1 to be a header one, ie actual data to be filtered begin from row 2 downwards
also this pastes values in target sheet from cell A1 downwards without blank rows. Should original row sequence be respected, it can be done
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.