Nhờ mọi người Code VBA chương trình tách thành từ file Excel riêng từ file tổng (1 người xem)

[baquang1984]

Em chào các anh chị trên diễn đàn giaiphapexcel.com!
Đối với chương trình tổng hợp từ nhiều file excel thành một file thì đã có và em đã ứng dụng được vào công việc của minh.
Tuy nhiên chương trình tách ra thành từng file Excel riêng biệt thì em lại chưa ứng dụng được vào công việc của mình. Em có một vấn đề nhờ anh chị giúp đỡ là em muốn tách dữ liệu thành từng file Excel riêng
Em có một file tổng "CSDL_BD" trong file này có rất nhiều tờ bản đồ, em đưa dữ liệu VD 6 tờ bản đồ giờ em muốn nhờ anh chị Code VBA giúp để tách thành từng file excel theo tờ bản đồ, điều kiện để tách là ở Cột "ToBanDo" và tên file được tách ra là "DC1, DC2, DC3 ...." lấy theo số của cột "ToBanDo". Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Em cảm ơn mọi người nhiều!

 

[leonguyenz]

Em chào các anh chị trên diễn đàn giaiphapexcel.com!
Đối với chương trình tổng hợp từ nhiều file excel thành một file thì đã có và em đã ứng dụng được vào công việc của minh.
Tuy nhiên chương trình tách ra thành từng file Excel riêng biệt thì em lại chưa ứng dụng được vào công việc của mình. Em có một vấn đề nhờ anh chị giúp đỡ là em muốn tách dữ liệu thành từng file Excel riêng
Em có một file tổng "CSDL_BD" trong file này có rất nhiều tờ bản đồ, em đưa dữ liệu VD 6 tờ bản đồ giờ em muốn nhờ anh chị Code VBA giúp để tách thành từng file excel theo tờ bản đồ, điều kiện để tách là ở Cột "ToBanDo" và tên file được tách ra là "DC1, DC2, DC3 ...." lấy theo số của cột "ToBanDo". Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Em cảm ơn mọi người nhiều!

Bài dạng này dùng ADO là hợp lý, mặt mạnh của Smod Hai Lúa Miền Tây, "buồn buồn" thì anh ấy viết dùm bạn, trong lúc chờ người khác, bạn thử Search từ khóa "ghi dữ liệu vào file đang đóng" xem thế nào, tham khảo và học được luôn càng tốt, vì ứng dụng cho bạn luôn mà. Tìm kiếm là 1 giải pháp hay để nâng cao tư duy và học hỏi thêm từ ý tưởng người khác.

 

[baquang1984]

Bài dạng này dùng ADO là hợp lý, mặt mạnh của Smod Hai Lúa Miền Tây, "buồn buồn" thì anh ấy viết dùm bạn, trong lúc chờ người khác, bạn thử Search từ khóa "ghi dữ liệu vào file đang đóng" xem thế nào, tham khảo và học được luôn càng tốt, vì ứng dụng cho bạn luôn mà.

Em cảm ơn anh, chắc là phải chờ rùi hix

 

[Quang_Hải]

Em chào các anh chị trên diễn đàn giaiphapexcel.com!
Đối với chương trình tổng hợp từ nhiều file excel thành một file thì đã có và em đã ứng dụng được vào công việc của minh.
Tuy nhiên chương trình tách ra thành từng file Excel riêng biệt thì em lại chưa ứng dụng được vào công việc của mình. Em có một vấn đề nhờ anh chị giúp đỡ là em muốn tách dữ liệu thành từng file Excel riêng
Em có một file tổng "CSDL_BD" trong file này có rất nhiều tờ bản đồ, em đưa dữ liệu VD 6 tờ bản đồ giờ em muốn nhờ anh chị Code VBA giúp để tách thành từng file excel theo tờ bản đồ, điều kiện để tách là ở Cột "ToBanDo" và tên file được tách ra là "DC1, DC2, DC3 ...." lấy theo số của cột "ToBanDo". Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Em cảm ơn mọi người nhiều!

Xài tạm code này. Tất cả file mới sẽ lưu chung vào thư mục của file hiện hành

Sub tach_file()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([N2], [N65536].End(3)).Value
Set Sdata = Range([A1], [A65536].End(3)).Resize(, 21)
For i = 1 To UBound(Data)
   If Data(i, 1) <> "" Then
      If Not Dic.exists(Data(i, 1)) Then
         Dic.Add Data(i, 1), ""
      End If
   End If
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 14, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         With .ActiveSheet
            .Name = "DC" & Ma
            .[A2].PasteSpecial 1
            .[A:N].Columns.AutoFit
         End With
         .SaveAs ThisWorkbook.Path & "\DC" & Ma, 51
         .Close
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[baquang1984]

Xài tạm code này. Tất cả file mới sẽ lưu chung vào thư mục của file hiện hành

Em cảm ơn anh Quanghai1969 chương trình của anh thật tuyệt vời, anh có thể cho chương trình lưu File ở định dạng .XLS, và Button được nằm ở Sheets khác được không ạ vì em chuyển nút bấm sang Sheets khác thì chương trình không chạy, Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Một lần nữa cảm ơn anh và mọi người trên diễn đàn nhiệt tình giúp đỡ!

 

[Quang_Hải]

Em cảm ơn anh Quanghai1969 chương trình của anh thật tuyệt vời, anh có thể cho chương trình lưu File ở định dạng .XLS, và Button được nằm ở Sheets khác được không ạ vì em chuyển nút bấm sang Sheets khác thì chương trình không chạy, Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Một lần nữa cảm ơn anh và mọi người trên diễn đàn nhiệt tình giúp đỡ!

Đổi số 51 thành số 18 thì sẽ lưu dạng .xls
Tạm thời xài vậy nha, vui thì viết tiếp. Giờ chưa vui mà.

 

[baquang1984]

Đổi số 51 thành số 18 thì sẽ lưu dạng .xls
Tạm thời xài vậy nha, vui thì viết tiếp. Giờ chưa vui mà.

Cảm ơn anh Quanghai1969 chúc anh luôn mạnh khoẻ và vui vẻ, để anh em diễn đang GPE những người cần có giải pháp như chúng em được học hỏi, áp dụng tri tuệ của các anh vào trong công việc
Cảm ơn anh!

 

[nghiaphuc]

Em cảm ơn anh Quanghai1969 chương trình của anh thật tuyệt vời, anh có thể cho chương trình lưu File ở định dạng .XLS, và Button được nằm ở Sheets khác được không ạ vì em chuyển nút bấm sang Sheets khác thì chương trình không chạy, Nếu có thêm thủ tục chọn đường dẫn đến thư mục lưu file tách ra thì tuyệt vời.
Một lần nữa cảm ơn anh và mọi người trên diễn đàn nhiệt tình giúp đỡ!

Thứ nhất: Đặt nút bấm ở sheet khác thì code không chạy là do tại các câu lệnh gán cho Data và Sdata, tên sheet không được chỉ định tường minh nên VBA hiểu đang thao tác với sheet hiện hành. Chỉ cần chỉnh chỗ này một chút là được.

Thứ hai: Để chọn thư mục cần lưu thì bạn có thể sử dụng một biến sPath và đối tượng BrowseForFolder để chọn thư mục. Cái vụ BrowseForFolder này tôi học từ bác siwtom tại bài này chứ thực chất tôi không hiểu về nó.

Tôi sửa lại một chút từ code của anh Quang Hải, đáp ứng các vấn đề của bạn. Trong code này, bạn chú ý các dòng lệnh: 6 --> 10, 12 --> 15 và 34. Ở đó tôi có sửa một chút so với code ban đầu.
[GPECODE=vb]Sub Tach_File()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object, sPath As String, oFolder As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
MsgBox "Chua chon thu muc luu": Exit Sub
End If
sPath = oFolder.Items.Item.Path
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Data = .Range(.[N2], .[N65536].End(3)).Value
Set Sdata = .Range(.[A1], .[A65536].End(3)).Resize(, 21)
End With
For i = 1 To UBound(Data)
If Data(i, 1) <> "" Then
If Not Dic.exists(Data(i, 1)) Then
Dic.Add Data(i, 1), ""
End If
End If
Next
For Each Ma In Dic.keys
With Sdata
.AutoFilter 14, Ma
.SpecialCells(12).Copy
Workbooks.Add
With ActiveWorkbook
With .ActiveSheet
.Name = "DC" & Ma
.[A2].PasteSpecial 1
.[A:N].Columns.AutoFit
End With
.SaveAs sPath & "\DC" & Ma, 18
.Close
End With
.AutoFilter
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub[/GPECODE]

 

[baquang1984]

Em cảm ơn anh!. Đúng là các cao thủ

Thứ nhất: Đặt nút bấm ở sheet khác thì code không chạy là do tại các câu lệnh gán cho Data và Sdata, tên sheet không được chỉ định tường minh nên VBA hiểu đang thao tác với sheet hiện hành. Chỉ cần chỉnh chỗ này một chút là được.

Thứ hai: Để chọn thư mục cần lưu thì bạn có thể sử dụng một biến sPath và đối tượng BrowseForFolder để chọn thư mục. Cái vụ BrowseForFolder này tôi học từ bác siwtom tại bài này chứ thực chất tôi không hiểu về nó.

Tôi sửa lại một chút từ code của anh Quang Hải, đáp ứng các vấn đề của bạn. Trong code này, bạn chú ý các dòng lệnh: 6 --> 10, 12 --> 15 và 34. Ở đó tôi có sửa một chút so với code ban đầu.
[GPECODE=vb]Sub Tach_File()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object, sPath As String, oFolder As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
MsgBox "Chua chon thu muc luu": Exit Sub
End If
sPath = oFolder.Items.Item.Path
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Data = .Range(.[N2], .[N65536].End(3)).Value
Set Sdata = .Range(.[A1], .[A65536].End(3)).Resize(, 21)
End With
For i = 1 To UBound(Data)
If Data(i, 1) <> "" Then
If Not Dic.exists(Data(i, 1)) Then
Dic.Add Data(i, 1), ""
End If
End If
Next
For Each Ma In Dic.keys
With Sdata
.AutoFilter 14, Ma
.SpecialCells(12).Copy
Workbooks.Add
With ActiveWorkbook
With .ActiveSheet
.Name = "DC" & Ma
.[A2].PasteSpecial 1
.[A:N].Columns.AutoFit
End With
.SaveAs sPath & "\DC" & Ma, 18
.Close
End With
.AutoFilter
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub[/GPECODE]