Chia file tổng thành nhiều file ứng với tên khu vực và mã code khu vực.

[dinhquangtrong]

Hiện em có vấn đề như vầy, em muốn tách file tổng là SP TOTAL, ra thành nhiều File nhỏ đặc tên theo khu vực. Ví dụ: An Giang sẽ đặt thành SP AN GIANG ...và tương tự. File mẫu em có đính kèm ở dưới. Cao nhân hỗ trợ cho em phần code VBA với. Em đội ơn anh chị.

 

[quanluu]

Hiện em có vấn đề như vầy, em muốn tách file tổng là SP TOTAL, ra thành nhiều File nhỏ đặc tên theo khu vực. Ví dụ: An Giang sẽ đặt thành SP AN GIANG ...và tương tự. File mẫu em có đính kèm ở dưới. Cao nhân hỗ trợ cho em phần code VBA với. Em đội ơn anh chị.

Bạn thử code này vậy

Sub TachFile()
Dim i, lr As Integer, wbmain As Workbook
Application.ScreenUpdating = False
lr = Range("B65000").End(3).Row
    Range("$B$2:$B$" & lr).Copy
    Range("R2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("$R$2:$R$" & lr).RemoveDuplicates Columns:=1, Header:=xlYes
    Set wbmain = ThisWorkbook
    For i = 3 To Range("R65000").End(3).Row
        Range("$B$2:$P$" & lr).AutoFilter Field:=1, Criteria1:=Cells(i, "R")
        Range("$B$2:$P$" & lr).SpecialCells(xlCellTypeVisible).Copy
        Workbooks.Add
        ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        ActiveWorkbook.Close True, wbmain.Path & "\PS " & wbmain.ActiveSheet.Cells(i, "R"), 51
    Next
    Range("$B$2:$P$" & lr).AutoFilter
    Range("$R$2:$R$" & lr).Clear
    Application.ScreenUpdating = True
End Sub

 

[dinhquangtrong]

Bạn thử code này vậy

Cảm ơn anh rất nhiều. Cho em tham lam xíu là em muốn copy thêm cái bảng mục tiêu và định dạng giống như file PS An Giang như vầy thì thêm code sao anh.

 

[quanluu]

Cảm ơn anh rất nhiều. Cho em tham lam xíu là em muốn copy thêm cái bảng mục tiêu và định dạng giống như file PS An Giang như vầy thì thêm code sao anh.

Mục tiêu khu vực nào cũng như nhau?

 

[dinhquangtrong]

Mục tiêu khu vực nào cũng như nhau?

Dạ đúng rồi anh ạ.....

 

[quanluu]

Dạ đúng rồi anh ạ.....

Bạn check code, format bạn làm trên file gốc nhé

Sub TachFile()
Dim i, lr As Integer, wbmain As Workbook, arr(1 To 4, 1 To 3), arr1(1 To 3, 1 To 2)
arr1(1, 1) = "TEN KHU VUC": arr1(2, 1) = "MA KHU VUC": arr1(3, 1) = "DATE": arr1(3, 2) = "FROM 1-2015 TO 12-2015":
arr(1, 1) = "MUC TIEU"
arr(1, 2) = "SO SAN PHAM": arr(2, 2) = "% SAN PHAM LOI": arr(3, 2) = "% SO SAN PHAM TON": arr(4, 2) = "THOI GIAN HOAN THANH SAN PHAM"
arr(1, 3) = "150": arr(2, 3) = "3%": arr(3, 3) = "10%": arr(4, 3) = "0:05"
Application.ScreenUpdating = False
lr = Range("B65000").End(3).Row
    Range("$B$2:$B$" & lr).Copy
    Range("R2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("$R$2:$R$" & lr).RemoveDuplicates Columns:=1, Header:=xlYes
    Set wbmain = ThisWorkbook
    For i = 3 To Range("R65000").End(3).Row
        Range("$B$2:$P$" & lr).AutoFilter Field:=1, Criteria1:=Cells(i, "R")
        Range("$B$2:$P$" & lr).SpecialCells(xlCellTypeVisible).Copy
        Workbooks.Add
        ActiveWorkbook.ActiveSheet.Range("A5").PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        Range("B1").Resize(3, 2) = arr1
        Cells(1, 3) = Cells(6, 1): Cells(2, 3) = Cells(6, 2)
        Range("B" & Range("B65000").End(3).Row + 2).Resize(4, 3) = arr
        ActiveWorkbook.Close True, wbmain.Path & "\PS " & wbmain.ActiveSheet.Cells(i, "R"), 51
    Next
    Range("$B$2:$P$" & lr).AutoFilter
    Range("$R$2:$R$" & lr).Clear
    Application.ScreenUpdating = True
End Sub

 

[dinhquangtrong]

Cảm ơn anh. Nếu giữ lại format của cái bảng MUC TIEU nữa thì hay quá.