在工作簿中的多個工作表上應用宏過濾器，並將過濾后的值另存為包含這些多個工作表的另一個工作簿

Question

我有一本包含23個工作表的工作簿。 我必須應用宏自動過濾器來過濾23個工作表中的所需數據，並將這些數據另存為工作簿，並在23個工作表中過濾數據。

     Sub Switch_Filter()
     Dim j As Integer, k As Integer, k1 As Integer
     Dim LastRow As Integer, i As Integer, erow As Integer
     Dim s As Variant, s1 As Variant


     j = Worksheets.Count


     s = InputBox("Enter Switch id")
     s1 = s & "*"
     If s <> vbNullString Then

     For k = 1 To 20
     If (k <> 1) And (k <> 4) And (k <> 7) Then
     With Worksheets(k)
     .UsedRange.AutoFilter field:=3, Criteria1:=s1


     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

     For i = 3 To LastRow


     Range(Cells(i, 1), Cells(i, 36)).Select
     Selection.Copy
     Workbooks.Open Filename:="C:\Users\takyar\Documents\salesmaster-new.xlsx"
     Worksheets(k).Select
     erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

     ActiveSheet.Cells(erow, 1).Select
     ActiveSheet.Paste
     ActiveWorkbook.Save
     ActiveWorkbook.Close
     Application.CutCopyMode = False


     Next i

     End With

     End If
     Next k
     End If
     End Sub

幾乎完成了，但是將過濾后的數據保存在新工作簿的同一張紙中，在這里我附加了代碼：-

     Sub Switch_Filter()
     Dim j As Integer, k As Integer
     Dim LastRow As Integer, i As Integer
     Dim s As Variant, s1 As Variant
     Dim MyWorkbook As Workbook, newWork As Workbook
     Set MyWorkbook = ThisWorkbook

     j = Worksheets.Count

     s = InputBox("Enter Switch id")
     s1 = s & "*"
     If s <> vbNullString Then

     For k = 1 To 20

     With Worksheets(k)
     Set MyWorkbook = ThisWorkbook
     If (k <> 1) And (k <> 4) And (k <> 7) Then

    .AutoFilterMode = False
        With Worksheets(k).UsedRange
            .AutoFilter
            .AutoFilter Field:=3, Criteria1:=s1
         End With
    End If

    MyWorkbook.Sheets(k).Rows("1:65000").Copy

    Set newWork = Workbooks.Open("E:\spreed sheet\sample1.xlsx")
    With newWork.Worksheets(k)
        Range("A2").PasteSpecial Paste:=xlPasteAll

        newWork.Close

    End With

    End With
    Next k
    End If
    End Sub

請給我一個解決方案。

提前致謝....！！！

Answer 1

甚至不確定這是否在執行，您實際上並沒有說出錯誤發生的位置。

沒有這些信息，我認為最大的問題是您一次要復制一行，並且每次要復制該行時都要打開和關閉工作簿。

如果您希望新工作簿包含所有單獨的工作表以及已過濾的數據，那么您可能要考慮在舊文檔中僅創建已過濾的數據來創建新工作表，並將其一次切割/移動到整個工作表中。 -那就是您可以通過記錄宏並手動執行代碼來學習代碼。

否則，如果您可以將這些數據全部存儲在一張紙/一張表中，建議將每個工作表及其過濾后的數據加載到一個單獨的數組中，然后打開新工作簿並從該數組中寫入所有信息。 此選項很可能是最快的。

Answer 2

終於得到答案了

      Sub Switch_Filter()
 Dim j As Integer, k As Integer
 Dim LastRow As Integer, i As Integer
 Dim s As Variant, s1 As Variant
 Dim MyWorkbook As Workbook, newWork As Workbook
 Dim ws As Worksheet, ws1 As Worksheet

 Dim name As String



 Set MyWorkbook = ThisWorkbook

 j = Worksheets.Count

 s = InputBox("Enter Switch id")
 s1 = s & "*"
 If s <> vbNullString Then

 For k = 1 To j

 With Worksheets(k)

 Set MyWorkbook = ThisWorkbook
 '.UsedRange.AutoFilter Field:=3, Criteria1:=s1
    If (k <> 1) And (k <> 4) And (k <> 7) And (k < 20) Then

    .AutoFilterMode = False
        With Worksheets(k).UsedRange
            .AutoFilter
            .AutoFilter Field:=3, Criteria1:=s1
         End With
    End If
 'LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    MyWorkbook.Sheets(k).Rows("1:65000").Copy

    Set newWork = Workbooks.Open("E:\spreed sheet\sample1.xlsx")


    Set ws = Sheets.Add
    name = ws.name

    With newWork.Sheets(name)

        Range("A2").PasteSpecial Paste:=xlPasteAll

        newWork.Close

    End With

 End With
 Next k
 End If
 End Sub