Xin giúp đỡ tách file tổng thành các file nhỏ theo điều kiện (1 người xem)

[yellowflash89]

Chào cả nhà !
Mình có một file tổng chứa thông tin các sản phẩm được nhập từ các kho khác nhau. Vì tính chất công việc nên mình cần lọc thông tin theo "Kho nhập" rồi copy ra từng file riêng biệt, ví dụ có 3 kho nhập thì tách ra 3 file. Mà số lương file như vậy là rất nhiều, làm thủ công mất quá nhiều thời gian.
Xin các anh chị em giúp đỡ mình code VBA có thể làm tự động được không ạ. Nếu được thì xin giúp đặt tên file theo tên "Kho nhập" luôn ạ.
Xin cảm ơn mọi người rất nhiều !

 

[befaint]

Chào cả nhà !
Mình có một file tổng chứa thông tin các sản phẩm được nhập từ các kho khác nhau. Vì tính chất công việc nên mình cần lọc thông tin theo "Kho nhập" rồi copy ra từng file riêng biệt, ví dụ có 3 kho nhập thì tách ra 3 file. Mà số lương file như vậy là rất nhiều, làm thủ công mất quá nhiều thời gian.
Xin các anh chị em giúp đỡ mình code VBA có thể làm tự động được không ạ. Nếu được thì xin giúp đặt tên file theo tên "Kho nhập" luôn ạ.
Xin cảm ơn mọi người rất nhiều !

http://www.giaiphapexcel.com/diendan/threads/hỏi-vba-tạo-sheet-tổng-hợp.127982/#post-801609

 

[vanthinh3101]

Chào cả nhà !
Mình có một file tổng chứa thông tin các sản phẩm được nhập từ các kho khác nhau. Vì tính chất công việc nên mình cần lọc thông tin theo "Kho nhập" rồi copy ra từng file riêng biệt, ví dụ có 3 kho nhập thì tách ra 3 file. Mà số lương file như vậy là rất nhiều, làm thủ công mất quá nhiều thời gian.
Xin các anh chị em giúp đỡ mình code VBA có thể làm tự động được không ạ. Nếu được thì xin giúp đặt tên file theo tên "Kho nhập" luôn ạ.
Xin cảm ơn mọi người rất nhiều !

Bạn lưu file dưới dạng .xlsm hoặc xlsb nhé!

Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long
    
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 11).Value
    For I = 1 To UBound(sArr)
        If Not Dic.Exists(sArr(I, 3)) Then Dic.Add sArr(I, 3), ""
    Next I
    
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        ReDim dArr(1 To UBound(sArr), 1 To 11)
        For I = 1 To UBound(sArr)
            If tArr(J) = sArr(I, 3) Then
                K = K + 1
                For N = 1 To 11
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:K1").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A2").Resize(K, 11) = dArr
            .Worksheets(1).Columns("A:K").AutoFit
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

 

[yellowflash89]

Bạn lưu file dưới dạng .xlsm hoặc xlsb nhé!

Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long
   
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 11).Value
    For I = 1 To UBound(sArr)
        If Not Dic.Exists(sArr(I, 3)) Then Dic.Add sArr(I, 3), ""
    Next I
   
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        ReDim dArr(1 To UBound(sArr), 1 To 11)
        For I = 1 To UBound(sArr)
            If tArr(J) = sArr(I, 3) Then
                K = K + 1
                For N = 1 To 11
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:K1").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A2").Resize(K, 11) = dArr
            .Worksheets(1).Columns("A:K").AutoFit
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

Mình làm được rồi. Cám ơn bạn rất nhiều!