Code Save As 1 file excel thành nhiều file nhỏ, mỗi file nhỏ lấy dựa theo giá trị cột B (1 người xem)

[LuuGiaPhúc]

Nhờ các anh chị giúp em code xuất file excel tổng hợp thành nhiều file nhỏ theo điều kiện như sau :
Lọc cột B theo tên từng văn phòng rồi save as từ cột B đến cột J thành 1 file mới, đặt tên theo quy tắc : thêm tên văn phòng đó vào trước tên file gốc.xlsx
Data của em thông thường có khoảng 65.000 ~ 80.000 hàng với khoảng 62 văn phòng ==> sẽ lưu thành 62 file.
Đây là 1 công việc hết sức thủ công và lặp đi lặp lại , nhưng lại dễ bị sót, nên em nghĩ nếu có 1 đoạn code export, nhấn vào sẽ xuất ra thành 62 file , lưu cùng thư mục với file tổng hợp hoặc nó có thể hỏi mình muốn lưu ở đâu chẳng hạn, rồi nó tự lọc từng văn phòng, lưu lại thì sẽ nhanh và không sợ bị sót.



ví dụ :
Lọc văn phòng BHO1 , xong thì save as khúc này thành 1 file mới , đặt tên là BHO1_DS HOAN TAT UL.XLSX , lưu cùng thư mục với file gốc.
Sau đó tiếp tục, lọc từng văn phòng , mỗi văn phòng sẽ lưu thành 1 file riêng biệt

 

[Maika8008]

File cho bạn. Sửa đường dẫn lưu file trong code.

 

[LuuGiaPhúc]

File cho bạn. Sửa đường dẫn lưu file trong code.

Code chạy được rồi. Giờ xin thêm 1 chút : có thể cho nó hỏi để mình chọn chỗ lưu file dc không ?
Nếu sửa trực tiếp trong cửa sổ VBA cũng được, tại mình nghĩ nếu cho nó hỏi để mình chọn chỗ lưu thì thấy hay hơn và linh động hơn, giúp mình 1 lần nữa nhé.
Cảm ơn bạn

 

[Hoàng Tuấn 868]

Ngại nhất đoạn không nêu vấn đề ngay từ đầu mà cứ thêm nhỏ giọt rồi hì hụi đi sửa code.

 

[LuuGiaPhúc]

Ngại nhất đoạn không nêu vấn đề ngay từ đầu mà cứ thêm nhỏ giọt rồi hì hụi đi sửa code.

Cảm ơn bạn đã góp ý, mình sẽ chú ý hơn nếu lần sau có đặt câu hỏi, tuy nhiên, có đôi khi lúc đặt câu hỏi thật sự mình chưa nghĩ tới vấn đề đó, rồi sau khi các bạn giúp được, mình sử dụng file vài lần, trong lúc sử dụng thì cái vấn đề "xin thêm" nó mới chợt nghĩ ra vì thấy thay vì mỗi lần làm mình lại phải mở cửa sổ VBA ra sửa đường dẫn lại hay là cho nó hỏi luôn thì tiện hơn. Bạn giúp mình nhé
Mình nghĩ là sẽ thay câu này bằng 1 dòng code nào đó hiện cái cửa sổ hỏi muốn lưu ở đâu, nhưng không biết cách làm
fPath = "C:\Users\miluu00\Downloads" & "\"

 

[ptm0412]

Code chạy được rồi. Giờ xin thêm 1 chút : có thể cho nó hỏi để mình chọn chỗ lưu file dc không ?
Nếu sửa trực tiếp trong cửa sổ VBA cũng được, tại mình nghĩ nếu cho nó hỏi để mình chọn chỗ lưu thì thấy hay hơn và linh động hơn, giúp mình 1 lần nữa nhé.
Cảm ơn bạn

Cách dễ mà không phải nhờ đó là ghi đường dẫn thư mục vào 1 ô trong file tổng. Code vào ô đó đọc

 

[Hoàng Tuấn 868]

Cảm ơn bạn đã góp ý, mình sẽ chú ý hơn nếu lần sau có đặt câu hỏi, tuy nhiên, có đôi khi lúc đặt câu hỏi thật sự mình chưa nghĩ tới vấn đề đó, rồi sau khi các bạn giúp được, mình sử dụng file vài lần, trong lúc sử dụng thì cái vấn đề "xin thêm" nó mới chợt nghĩ ra vì thấy thay vì mỗi lần làm mình lại phải mở cửa sổ VBA ra sửa đường dẫn lại hay là cho nó hỏi luôn thì tiện hơn. Bạn giúp mình nhé
Mình nghĩ là sẽ thay câu này bằng 1 dòng code nào đó hiện cái cửa sổ hỏi muốn lưu ở đâu, nhưng không biết cách làm
fPath = "C:\Users\miluu00\Downloads" & "\"

Chính chủ sửa thì hợp lý hơn bạn à.

 

[giaiphap]

Cảm ơn bạn đã góp ý, mình sẽ chú ý hơn nếu lần sau có đặt câu hỏi, tuy nhiên, có đôi khi lúc đặt câu hỏi thật sự mình chưa nghĩ tới vấn đề đó, rồi sau khi các bạn giúp được, mình sử dụng file vài lần, trong lúc sử dụng thì cái vấn đề "xin thêm" nó mới chợt nghĩ ra vì thấy thay vì mỗi lần làm mình lại phải mở cửa sổ VBA ra sửa đường dẫn lại hay là cho nó hỏi luôn thì tiện hơn. Bạn giúp mình nhé
Mình nghĩ là sẽ thay câu này bằng 1 dòng code nào đó hiện cái cửa sổ hỏi muốn lưu ở đâu, nhưng không biết cách làm
fPath = "C:\Users\miluu00\Downloads" & "\"

Mượn code #2 thêm chút nửa là xong.

Sub ExportFiles()
    Dim arr(), Dic As Object, Rng As Range, Wb As Workbook
    Dim i&, k&, endR&, dKey$, fPath$, fName$, tmr#
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Select"
        If .Show = -1 Then ' if OK is pressed
            fPath = .SelectedItems(1)
        End If
    End With
    If fPath <> "" Then
        tmr = Timer()
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        fPath = fPath & "\"
        If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False
        endR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
        Set Rng = Sheet1.Range("A5:J" & endR)
        Rng.AutoFilter
        Set Dic = CreateObject("Scripting.Dictionary")
        For i = 2 To Rng.Rows.Count
            dKey = Rng(i, 2)
            If Not Dic.Exists(dKey) Then
                k = k + 1
                Dic.Add dKey, k
                ReDim Preserve arr(1 To k)
                arr(k) = dKey
            End If
        Next
        For i = 1 To k
            Rng.AutoFilter 2, arr(i)
            Union(Sheet1.Range("A1:J4"), Rng).SpecialCells(xlCellTypeVisible).Copy
            Set Wb = Workbooks.Add
            Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
            fName = arr(i) & "_DS HOAN TAT UL.xlsx"
            Wb.Close True, fPath & fName
            Set Wb = Nothing
        Next
        Set Dic = Nothing
        MsgBox "Done!" & vbNewLine & Timer() - tmr & " seconds"
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

 

[LuuGiaPhúc]

Mượn code #2 thêm chút nửa là xong.

Sub ExportFiles()
    Dim arr(), Dic As Object, Rng As Range, Wb As Workbook
    Dim i&, k&, endR&, dKey$, fPath$, fName$, tmr#
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Select"
        If .Show = -1 Then ' if OK is pressed
            fPath = .SelectedItems(1)
        End If
    End With
    If fPath <> "" Then
        tmr = Timer()
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        fPath = fPath & "\"
        If Sheet1.AutoFilterMode Then Sheet1.AutoFilterMode = False
        endR = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
        Set Rng = Sheet1.Range("A5:J" & endR)
        Rng.AutoFilter
        Set Dic = CreateObject("Scripting.Dictionary")
        For i = 2 To Rng.Rows.Count
            dKey = Rng(i, 2)
            If Not Dic.Exists(dKey) Then
                k = k + 1
                Dic.Add dKey, k
                ReDim Preserve arr(1 To k)
                arr(k) = dKey
            End If
        Next
        For i = 1 To k
            Rng.AutoFilter 2, arr(i)
            Union(Sheet1.Range("A1:J4"), Rng).SpecialCells(xlCellTypeVisible).Copy
            Set Wb = Workbooks.Add
            Wb.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteAll
            fName = arr(i) & "_DS HOAN TAT UL.xlsx"
            Wb.Close True, fPath & fName
            Set Wb = Nothing
        Next
        Set Dic = Nothing
        MsgBox "Done!" & vbNewLine & Timer() - tmr & " seconds"
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

Cảm ơn bạn nhiều lắm . Đúng như ý rồi.

 

[Maika8008]

Cảm ơn bạn nhiều lắm . Đúng như ý rồi.

Thế là khỏi cần tôi phải động tay nhỉ

 

[LuuGiaPhúc]

Thế là khỏi cần tôi phải động tay nhỉ

hihi, các bạn trên diễn đàn này quá hay và nhiệt tình luôn, mình cảm ơn rất nhiều