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