Đưa kết quả sau khi lọc vào các Sheet của cùng 1 File (1 người xem)

[nth09061985]

Em có 1 File ("File_Goc") em đã tạo được 1 nút để lọc tự động dữ liệu. Tuy nhiên em muốn sau mỗi lần lọc thì kết quả lọc được sẽ được copy tới 1 Sheet mới (Tên sheet mới được đặt tên theo ô E1), mỗi kết quả lọc được đưa vào 1 sheet riêng. Tất cả các Sheet chứa kết quả LOC dược này nằm trong cùng 1 File.("FileKet_Qua").

Option Explicit
Sub test()
Dim i As Long, dk As String, bd As Range
Set bd = Sheet1.Range("Q1:Q4")
For i = 1 To bd.Rows.Count
    Sheet1.Range("E1") = bd(i, 1)
    ActiveSheet.Range("$A$2:$C$2").AutoFilter Field:=3, Criteria1:=Sheet1.Range("E1")
    MsgBox "Duoc " & i & " em"
    '[B][COLOR=#ff0000]Nho anh chi giup em doan code de sau moi lan LOC la no se tu dong luu thanh 1 sheet trong 1 File moi.[/COLOR][/B]
Next i
ActiveSheet.Range("$A$2:$C$2").AutoFilter
MsgBox "Hoan thanh!"
End Sub

Kết quả mong muốn em để trong File đính kèm ạ!
Mong anh chị và các bạn giúp đỡ!
P/S: Em muốn hỏi thêm liệu mình có thể tạo ra 1 File ("FileKet_Qua")mới bằng code luôn được không ạ hay mình phải tạo File này trước! Nếu tạo được bằng code mong anh chị giúp đỡ! Em chân thành cảm ơn!

 

[nth09061985]

Mong các thành viên giúp đỡ em với ạ!

 

[doveandrose]

Sub test()
Dim dic As Object, rngC As Variant, lr As Long, r As Long
Dim tempKey As Variant, dataRG As Range, wb As Workbook, ws As Worksheet
Set dic = CreateObject("Scripting.Dictionary")
lr = Sheet1.Range("C1000000").End(xlUp).Row
If lr > 2 Then
    Application.ScreenUpdating = False
    rngC = Sheet1.Range("C3:C" & lr).Value
    If Not IsArray(rngC) Then
        ReDim rngC(1 To 1, 1 To 1)
        rngC(1, 1) = Sheet1.Range("C3").Value
    End If
    Set dataRG = Sheet1.Range("A2:C" & lr)
    Set wb = Workbooks.Add
    For r = 1 To UBound(rngC) Step 1
        dic(rngC(r, 1)) = 1
    Next
    
    For Each tempKey In dic.keys()
        Set ws = wb.Worksheets.Add
        ws.Name = tempKey
        With dataRG
            .AutoFilter 3, tempKey
            .SpecialCells(xlCellTypeVisible).Copy
            ws.Range("A1").PasteSpecial xlPasteValues
            .AutoFilter
        End With
    Next
    Application.DisplayAlerts = False
    wb.SaveAs ThisWorkbook.Path & "\" & IIf(Sheet1.Range("F1").Value = "", "new book", Sheet1.Range("F1").Value)
    wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If
End Sub

 

[nth09061985]

Sub test()
Dim dic As Object, rngC As Variant, lr As Long, r As Long
Dim tempKey As Variant, dataRG As Range, wb As Workbook, ws As Worksheet
Set dic = CreateObject("Scripting.Dictionary")
lr = Sheet1.Range("C1000000").End(xlUp).Row
If lr > 2 Then
    Application.ScreenUpdating = False
    rngC = Sheet1.Range("C3:C" & lr).Value
    If Not IsArray(rngC) Then
        ReDim rngC(1 To 1, 1 To 1)
        rngC(1, 1) = Sheet1.Range("C3").Value
    End If
    Set dataRG = Sheet1.Range("A2:C" & lr)
    Set wb = Workbooks.Add
    For r = 1 To UBound(rngC) Step 1
        dic(rngC(r, 1)) = 1
    Next
    
    For Each tempKey In dic.keys()
        Set ws = wb.Worksheets.Add
        ws.Name = tempKey
        With dataRG
            .AutoFilter 3, tempKey
            .SpecialCells(xlCellTypeVisible).Copy
            ws.Range("A1").PasteSpecial xlPasteValues
            .AutoFilter
        End With
    Next
    Application.DisplayAlerts = False
    wb.SaveAs ThisWorkbook.Path & "\" & IIf(Sheet1.Range("F1").Value = "", "new book", Sheet1.Range("F1").Value)
    wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If
End Sub

Chưa Test nhưng cảm ơn bạn trước nha. Có gì tôi hồi âm!