Tự động tách File excel tổng ra thành nhiều file excel mới theo điều kiện !?

lttdac · 3/5/16

Em có File excel như đính kèm (File: tong.xls).

Bây giờ em muốn lưu riêng ra từng file excel mà trong đó dựa theo mã đơn vị (cột "madvi" trong file đính kèm ),
cứ dòng nào mà có trường "madvi" giống nhau là lưu riêng vào 1 file. (như đính kèm File: QW0007Z và File: TA0090A)

Có cách nào tự động tạo file excel với tên file theo trường "madvi" và tên sheet chứa dữ liệu cũng theo trường "madvi" không ạ? (như file đính kèm: QW0007Z và TA0090A)

Vì cơ sở dữ liệu trong file excel có đến hơn 1000 mã luôn ạ! nên em ko làm thủ công nổi!

quanluu · 3/5/16

lttdac đã viết:
Em có File excel như đính kèm (File: tong.xls).

Bây giờ em muốn lưu riêng ra từng file excel mà trong đó dựa theo mã đơn vị (cột "madvi" trong file đính kèm ),
cứ dòng nào mà có trường "madvi" giống nhau là lưu riêng vào 1 file. (như đính kèm File: QW0007Z và File: TA0090A)

Có cách nào tự động tạo file excel với tên file theo trường "madvi" và tên sheet chứa dữ liệu cũng theo trường "madvi" không ạ? (như file đính kèm: QW0007Z và TA0090A)

Vì cơ sở dữ liệu trong file excel có đến hơn 1000 mã luôn ạ! nên em ko làm thủ công nổi!

Bạn nhận file nhé.

lttdac · 3/5/16

quanluu1989 đã viết:
Bạn nhận file nhé.

Mình thêm dữ liệu vào thì báo lỗi nè, mình ko biết vì sao!

quanluu · 3/5/16

lttdac đã viết:
Mình thêm dữ liệu vào thì báo lỗi nè, mình ko biết vì sao!

Đã update, bạn dùng Ctrl + Shift + R để chạy nhé.

lttdac · 3/5/16

quanluu1989 đã viết:
Đã update, bạn dùng Ctrl + Shift + R để chạy nhé.

đến hiện tại file bạn update chạy rất tốt!
mình xin phép up lên để ai cần lấy về dùng!

lttdac · 3/5/16

Nếu cũng là file "tong.xls" nhưng khi xuất ra file con như trên nhưng tên và vị trí các cột có thay đổi mình làm đc ko ạ !

Ví dụ: 1 File con như File đính kèm!

haiphusy · 4/5/16

Mình có 1 file tương tự, nhờ các bạn giúp để tách file theo dữ liệu của cột A và lưu thành từng file theo các tên của cột A

Cho mình hỏi thêm là có thể tách ra và vẫn giữ được các hàng trông để chia giữa các hàng dữ liệu không

Cám ơn các bạn rất nhiều

lttdac · 5/5/16

hpkhuong đã viết:

Code cho #1

Mã:

Public Sub GPE_001()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet
Dim I As Long, K As Long, WbMain As Workbook, Rng As Range, Sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("bc04261355")
Set Rng = ShMain.Range("A1").CurrentRegion
Pth = ActiveWorkbook.Path
Arr = ShMain.Range("B2", ShMain.Range("B65000").End(3)).Value
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For I = 1 To UBound(Arr)
Tmp = Arr(I, 1)
    If Not .Exists(Tmp) Then
        K = K + 1
        .Add Tmp, K
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Sh.Name = ShMain.Name
            Rng.AutoFilter 2, Tmp
            ShMain.Range("A1", Rng).SpecialCells(12).Copy
            Sh.Range("A1").PasteSpecial xlPasteColumnWidths
            Sh.Range("A1").PasteSpecial xlPasteValues
            Sh.Range("A1").PasteSpecial xlPasteFormats
            Rng.AutoFilter
            ActiveWorkbook.Close True, Pth & "\" & Tmp & ".xlsx"
        End With
    End If
Next I
End With
Set Dic = Nothing
ShMain.AutoFilterMode = False
Application.CutCopyMode = False
Application.SheetsInNewWorkbook = 3
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Code cho #6

Mã:

Public Sub GPE_002()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet, sArr, dArr, N As Long
Dim I As Long, K As Long, WbMain As Workbook, Sh As Worksheet, Col As Long, J As Long
sArr = Array("stt", "sobhxh", "sokcb", "madt", "hoten", "ngaysinh", "gioitinh", "noikhai", "diachi", "diachihk", "tamtru", _
"noicapso", "mapb", "socmnd", "ngaycmnd", "noicap", "ma_tinh", "ma_bv", "dantoc", "quoctich", "hsl", "ml", "pa", "tuthang", _
"denthang", "tyle", "congviec", "macv")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("bc04261355")
Arr = ShMain.Range("A1").CurrentRegion
ReDim dArr(1 To UBound(Arr), 1 To UBound(sArr) + 1)
Pth = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For J = 2 To UBound(Arr)
Tmp = Arr(J, 2)
    If Not .Exists(Tmp) Then
        N = N + 1
        .Add Tmp, N
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Sh.Name = Tmp
            For Col = 0 To UBound(sArr)
                dArr(1, Col + 1) = sArr(Col)
            Next Col
            K = 1
            For I = 2 To UBound(Arr)
                If Arr(I, 2) = Tmp Then
                    K = K + 1
                    dArr(K, 1) = K - 1
                    dArr(K, 2) = Arr(I, 3)
                    dArr(K, 3) = Arr(I, 8)
                    dArr(K, 5) = Arr(I, 4) & " " & Arr(I, 5)
                    dArr(K, 6) = Arr(I, 6)
                    If Arr(I, 7) = 0 Then dArr(K, 7) = "x"
                    dArr(K, 9) = Arr(I, 12)
                    dArr(K, 13) = Arr(I, 15)
                    dArr(K, 14) = Arr(I, 9)
                    dArr(K, 15) = Arr(I, 10)
                    dArr(K, 16) = Arr(I, 11)
                    dArr(K, 17) = Arr(I, 13)
                    dArr(K, 18) = Arr(I, 14)
                    dArr(K, 21) = Arr(I, 20)
                    dArr(K, 22) = Arr(I, 17)
                    dArr(K, 23) = Arr(I, 27)
                    dArr(K, 28) = Arr(I, 29)
                End If
            Next I
            Sheets(Tmp).Range("A1").Offset(, 1).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Offset(, 13).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Offset(, 17).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Resize(K, UBound(sArr) + 1).Value = dArr
            Sheets(Tmp).Range("A1").Resize(K, UBound(sArr) + 1).Font.Name = ".VnTime"
            .Close True, Pth & "\" & Tmp & ".xlsx"
        End With
    End If
Next J
End With
Set Dic = Nothing
Application.SheetsInNewWorkbook = 3
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Mình cảm ơn rất nhiều ạ!

lttdac · 16/5/16

hpkhuong đã viết:

Code cho #1

Mã:

Public Sub GPE_001()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet
Dim I As Long, K As Long, WbMain As Workbook, Rng As Range, Sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("bc04261355")
Set Rng = ShMain.Range("A1").CurrentRegion
Pth = ActiveWorkbook.Path
Arr = ShMain.Range("B2", ShMain.Range("B65000").End(3)).Value
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For I = 1 To UBound(Arr)
Tmp = Arr(I, 1)
    If Not .Exists(Tmp) Then
        K = K + 1
        .Add Tmp, K
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Sh.Name = ShMain.Name
            Rng.AutoFilter 2, Tmp
            ShMain.Range("A1", Rng).SpecialCells(12).Copy
            Sh.Range("A1").PasteSpecial xlPasteColumnWidths
            Sh.Range("A1").PasteSpecial xlPasteValues
            Sh.Range("A1").PasteSpecial xlPasteFormats
            Rng.AutoFilter
            ActiveWorkbook.Close True, Pth & "\" & Tmp & ".xlsx"
        End With
    End If
Next I
End With
Set Dic = Nothing
ShMain.AutoFilterMode = False
Application.CutCopyMode = False
Application.SheetsInNewWorkbook = 3
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Code cho #6

Mã:

Public Sub GPE_002()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet, sArr, dArr, N As Long
Dim I As Long, K As Long, WbMain As Workbook, Sh As Worksheet, Col As Long, J As Long
sArr = Array("stt", "sobhxh", "sokcb", "madt", "hoten", "ngaysinh", "gioitinh", "noikhai", "diachi", "diachihk", "tamtru", _
"noicapso", "mapb", "socmnd", "ngaycmnd", "noicap", "ma_tinh", "ma_bv", "dantoc", "quoctich", "hsl", "ml", "pa", "tuthang", _
"denthang", "tyle", "congviec", "macv")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("bc04261355")
Arr = ShMain.Range("A1").CurrentRegion
ReDim dArr(1 To UBound(Arr), 1 To UBound(sArr) + 1)
Pth = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For J = 2 To UBound(Arr)
Tmp = Arr(J, 2)
    If Not .Exists(Tmp) Then
        N = N + 1
        .Add Tmp, N
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Sh.Name = Tmp
            For Col = 0 To UBound(sArr)
                dArr(1, Col + 1) = sArr(Col)
            Next Col
            K = 1
            For I = 2 To UBound(Arr)
                If Arr(I, 2) = Tmp Then
                    K = K + 1
                    dArr(K, 1) = K - 1
                    dArr(K, 2) = Arr(I, 3)
                    dArr(K, 3) = Arr(I, 8)
                    dArr(K, 5) = Arr(I, 4) & " " & Arr(I, 5)
                    dArr(K, 6) = Arr(I, 6)
                    If Arr(I, 7) = 0 Then dArr(K, 7) = "x"
                    dArr(K, 9) = Arr(I, 12)
                    dArr(K, 13) = Arr(I, 15)
                    dArr(K, 14) = Arr(I, 9)
                    dArr(K, 15) = Arr(I, 10)
                    dArr(K, 16) = Arr(I, 11)
                    dArr(K, 17) = Arr(I, 13)
                    dArr(K, 18) = Arr(I, 14)
                    dArr(K, 21) = Arr(I, 20)
                    dArr(K, 22) = Arr(I, 17)
                    dArr(K, 23) = Arr(I, 27)
                    dArr(K, 28) = Arr(I, 29)
                End If
            Next I
            Sheets(Tmp).Range("A1").Offset(, 1).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Offset(, 13).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Offset(, 17).Resize(K).NumberFormat = "@"
            Sheets(Tmp).Range("A1").Resize(K, UBound(sArr) + 1).Value = dArr
            Sheets(Tmp).Range("A1").Resize(K, UBound(sArr) + 1).Font.Name = ".VnTime"
            .Close True, Pth & "\" & Tmp & ".xlsx"
        End With
    End If
Next J
End With
Set Dic = Nothing
Application.SheetsInNewWorkbook = 3
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Bạn ơi, mình thử với File Excel khoảng 900.000 dòng thì báo lỗi Out of memory!

doveandrose · 19/5/16

hpkhuong đã viết:
Ừ lỗi này là lỗi kinh điển khi xài Array... Lỗi này chịu không cách khắc phục khi xài array...

trong lúc căng thẳng anh hpkhuong nên tìm đọc truyên ông trạng Lương Thế Vinh cân voi , biết đâu lại tìm ra ý tưởng khắc phục cho vấn đề này chăng ?

Tự động tách File excel tổng ra thành nhiều file excel mới theo điều kiện !?

lttdac

Thành viên mới

File đính kèm

quanluu

Thành viên gắn bó

File đính kèm

lttdac

Thành viên mới

File đính kèm

quanluu

Thành viên gắn bó

lttdac

Thành viên mới

File đính kèm

lttdac

Thành viên mới

File đính kèm

haiphusy

Thành viên mới

File đính kèm

lttdac

Thành viên mới

lttdac

Thành viên mới

doveandrose

hello

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian