Cắt file Excel theo cụm (1 người xem)

lptinfo40 · 26/11/15

Chào các anh/chị,

Hiện tại mình đang có 1 file gần giống như file đính kèm và mình muốn cắt nó ra từng file Excel dựa trên Mã số (như trong file). Theo như bình thường thì mình sẽ filter cột Mã số, chọn từng giá trị và cắt nó ra 1 file Excel mới với tên file là Mã số đó, cứ làm lần lượt như vậy cho đến hết.
Ví dụ mã số 1001 thì file Excel mới sẽ có tên là 1001.
Nhưng file mình đang làm hiện tại có đến hơn 500 Mã số như vậy, nếu cắt file như cách filter như trên thì +-+-+-+

Các anh/chị có cách nào giúp em với.
Em cảm ơn nhiều @$@!^%

lptinfo40 · 26/11/15

hpkhuong đã viết:

Mã:

Option Explicit
Sub GPE()
Dim Dic As Object, Tmp, Ms
Dim I As Long, K As Long, RngF As Range
Dim Arr, dArr, Rng As Range, Sh1 As Worksheet, Sh2 As Worksheet
Application.ScreenUpdating = False
Arr = Sheet1.Range(Sheet1.[A2], Sheet1.[A65000].End(3))
ReDim dArr(1 To UBound(Arr), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
    For I = 1 To UBound(Arr, 1)
    Tmp = Arr(I, 1)
        If Not .Exists(Tmp) Then
            K = K + 1
            .Add Tmp, K
                dArr(K, 1) = Arr(I, 1)
        End If
    Next I
End With
    Sheet1.Range("L2").Resize(K) = dArr
On Error Resume Next
Set Sh1 = ThisWorkbook.Sheets("Sheet1")
Set Rng = Sh1.Range(Sh1.[A1], Sh1.[A65000].End(3)).Resize(, 2)
Set RngF = Sh1.Range(Sh1.[L2], Sh1.[L65000].End(3))
For Each Ms In RngF
    With Workbooks.Add
        Set Sh2 = .Sheets(1)
        Rng.AutoFilter 1, Ms
        Sh1.Range(Sh1.Range("A1"), Rng).SpecialCells(12).Copy
        Sh2.Range("A1").PasteSpecial 8
        Sh2.Range("A1").PasteSpecial
        Rng.AutoFilter
        Application.DisplayAlerts = False
        .Close True, ThisWorkbook.Path & "\" & Ms & ".xlsx"
        Application.DisplayAlerts = True
    End With
Next Ms
    RngF.ClearContents
Application.ScreenUpdating = True
End Sub

Cảm ơn bạn, mình đã làm được @$@!^%

, nhưng ví dụ mình có thêm cột nữa thì sao bạn? Khi mình chạy code của bạn, nó chỉ cắt cột A và B, mình thêm cột nữa nó không chạy được.

lptinfo40 · 26/11/15

hpkhuong đã viết:
Tôi biết ngay sẽ hỏi vậy. Thế sao lúc hỏi ko chịu làm file thật...gồm bao nhiêu cột bố trí như nào...mà làm có 2 cột...
Úp lại file như thật thì tôi sửa code lại...bằng không bạn tự xử đi nhé!

Xin lỗi bạn vì mình chưa Úp file kia lên được, vì mình đang làm template cho nó và chưa nhận được data

Mình Up template dự thảo của mình nhé! Cột được filter để lấy dữ liệu là cột T (Mã số NV CBQL).
Do đây chưa phải là template chính thức, mình có thể tùy biến (thêm hoặc xóa) cột được không bạn?

Cảm ơn bạn nhiều nhé. @$@!^%

VetMini · 27/11/15

Đây là một trong những đề tài dùng ADO khá hiệu quả.
1. Đọc sheet, "select distinct MaSo from sheet"
2. ghi xuống một bảng tạm, hoặc cho vào array
3. For each MS in BangTam
3.1 Mở file MS
3.2 "select * from Sheet where MaSo = MS"
3.3 ghi vào file, đóng và save file
4. Next MS
5. Đóng file chính, không save

phihndhsp · 27/11/15

hpkhuong đã viết:
Nhưng ADO nó chỉ copy value. Cái họ cần là copy luôn định dạng của sheet (file) đang làm ấy anh!
Chứ chỉ muốn copy value thì quả ADO ngon lành rồi...

nếu muốn copy luôn định dạng thì mình có thể tạo 1 cái macro tạo mới một file từ cái file đã được định dạng, rồi có thể sử dụng ADO giải quyết

VetMini · 27/11/15

Tôi chỉ nói về giải thuật.

Muón màu mè thì phải biết biến chế. Ví dụ tạo một cái file mẫu, chỉ định dạng, dữ liệu để trống. Chép dữ liệu vào file này và save với tên khác.

Tuy nhiên, với cái này thi định dạng làm chi cho mệt, file có phải là dạng cố định đâu?

...mình có thể tùy biến (thêm hoặc xóa) cột được không bạn?...

ndu96081631 · 27/11/15

hpkhuong đã viết:
File như nào thì code thế ấy. Code không có vụ thích xóa cột nào thì xóa... Cái gì cũng có quy định của nó. Muốn làm gì thì làm sao nó chuẩn được...

P/s: tốt nhất đưa file thật lên. Không rảnh đâu mà ngồi sửa cho bạn mỗi ngày mỗi tí được...

Mã:

Option Explicit Sub GPE() ................. For I = 1 To UBound(Arr, 1) ..................... Next I For Each Ms In RngF ..................... Next Ms .............. End Sub

Mình nghĩ bài này chỉ 1 vòng lập là đủ

doveandrose · 27/11/15

ndu96081631 đã viết:
Mình nghĩ bài này chỉ 1 vòng lập là đủ

và chắc không phải mời mình . hí hí

giangleloi · 27/11/15

hpkhuong đã viết:
Ý anh là: không cần dán kết quả của Dic xuống Range. Mà lấy kết quả của Dic lần lượt filter & tách file luôn????

Cách đó làm như thế nào vậy, làm luôn cho nó "nóng" đi chàng.

doveandrose · 27/11/15

VetMini đã viết:
Đây là một trong những đề tài dùng ADO khá hiệu quả.
1. Đọc sheet, "select distinct MaSo from sheet"
2. ghi xuống một bảng tạm, hoặc cho vào array
3. For each MS in BangTam
3.1 Mở file MS
3.2 "select * from Sheet where MaSo = MS"
3.3 ghi vào file, đóng và save file
4. Next MS
5. Đóng file chính, không save

chưa gì anh lột trần trụi ra hết rùi sao còn hứng được nữa
anh chỉ nên nói 1 câu
có bạn nào muốn thử sức ADO hôn ?

ndu96081631 · 27/11/15

hpkhuong đã viết:
Ý anh là: không cần dán kết quả của Dic xuống Range. Mà lấy kết quả của Dic lần lượt filter & tách file luôn????

Tức là lúc Dic.Add thì ta "mần" luôn cái vụ filter và tách file gì đó luôn
(bỏ qua khúc này quá uổng phí)
----------------

doveandrose đã viết:
và chắc không phải mời mình . hí hí

Vụ gì vậy Diễm? Nhậu cứ đợi mời không là sao?

doveandrose · 27/11/15

hpkhuong đã viết:
Đã thử. Nhưng còn vướng cái chỗ làm Sao save được file, đang ở vòng lặp I nên nó không có save được. Mà vẫn Open ->chờ save = tay..... Úp lên cho quý vị giải giúp!!!

sao dạo này nhiều người thích giả vờ làm sai để giúp tôi nhớ bài lâu vẩy ?
xin cho biết ý nghĩa dòng này

Mã:

[COLOR=#000000]Ms = Dic.keys[/COLOR]

doveandrose · 27/11/15

hpkhuong đã viết:
Um thì nó là cái Tmp ở trên thôi mà. Làm vầy cho nhớ bài...
Giúp tôi cái vụ save file đi...
------------------------
Với lại trong quá trình test, thấy để Dic.Keys không bị sai. Còn trực tiếp Tmp vào filter nó sai tè le...

thôi tôi không biết gì đâu , núp đây . ha ha

huuthang_bd · 27/11/15

Làm theo cách dân dã: Sort; Dùng Find tìm dòng đầu, dòng cuối; Copy

PHP:

Sub ABC()
Dim Rng As Range, EndRow As Long, FCll As Range, LCll As Range, DataSh As Worksheet, TmpSh As Worksheet
Sheet1.Copy
Set DataSh = ActiveSheet
DataSh.Copy DataSh
Set TmpSh = ActiveSheet
With DataSh
    EndRow = .Cells(&H100000, "T").End(xlUp).Row
    .Range("A7:V" & EndRow).Sort .Range("T7"), xlAscending
    Set Rng = .Range("A7:V" & EndRow)
    Set FCll = .Range("T7")
    Do
        Set LCll = Rng.Columns("T").Find(FCll.Value, FCll, xlValues, xlWhole, , xlPrevious, , , False)
        TmpSh.Range("A7:V" & EndRow).Clear
        .Range("A" & FCll.Row & ":V" & LCll.Row).Copy TmpSh.Range("A7")
        TmpSh.Copy
        ActiveWorkbook.Close True, ThisWorkbook.Path & "/" & FCll.Value & ".xlsx"
        Set FCll = LCll.Offset(1)
    Loop Until LCll.Row = EndRow
    DataSh.Parent.Close False
End With
End Sub

huuthang_bd · 27/11/15

ADO dịch từ lời >> code

VetMini đã viết:
Đây là một trong những đề tài dùng ADO khá hiệu quả.
1. Đọc sheet, "select distinct MaSo from sheet"
2. ghi xuống một bảng tạm, hoặc cho vào array
3. For each MS in BangTam
3.1 Mở file MS
3.2 "select * from Sheet where MaSo = MS"
3.3 ghi vào file, đóng và save file
4. Next MS
5. Đóng file chính, không save

PHP:

Sub ADO()
Dim Cn As Object, Rst As Object, UniqueArr, i As Long, LB1 As Long, EndRow As Long, TmpSh As Worksheet
EndRow = Sheet1.Cells(&H100000, "T").End(xlUp).Row
Sheet1.Copy Sheet1
Set TmpSh = ActiveSheet
TmpSh.Range("A7:V" & EndRow).Clear
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
    ";Extended Properties=""Excel 12.0;HDR=No;ReadOnly=True"";"
UniqueArr = Cn.Execute("Select Distinct F1 From [Sheet1$T7:T]").GetRows
LB1 = LBound(UniqueArr, 1)
For i = LBound(UniqueArr, 2) To UBound(UniqueArr, 2)
    TmpSh.Copy
    ActiveSheet.Range("A7").CopyFromRecordset Cn.Execute("Select * From [Sheet1$A7:V" & EndRow & "] Where F20 = '" & UniqueArr(LB1, i) & "'")
    ActiveWorkbook.Close True, ThisWorkbook.Path & "/" & UniqueArr(LB1, i) & ".xlsx"
Next
Application.DisplayAlerts = False
TmpSh.Delete
Application.DisplayAlerts = True
End Sub

babe_nice · 11/12/15

hpkhuong đã viết:

Đã thử. Nhưng còn vướng cái chỗ làm Sao save được file, đang ở vòng lặp I nên nó không có save được. Mà vẫn Open ->chờ save = tay.... --=0

. Úp lên cho quý vị giải giúp!!!

Mã:

Sub GPE_()
Dim Dic As Object, Tmp, Ms, I As Long
Dim Arr, Rng As Range, Sh1 As Worksheet, Sh2 As Worksheet
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Arr = Range(.[T7], .[T65000].End(3))
End With
Set Sh1 = ThisWorkbook.Sheets("Sheet1")
Set Rng = Sh1.Range(Sh1.[A6], Sh1.[A65000].End(3)).Resize(, Sh1.[A4].End(2).Column)
Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(Arr, 1)
    Tmp = Arr(I, 1)
        If Not Dic.Exists(Tmp) Then
            Dic.Add Tmp, ""
            Ms = Dic.keys
        With Workbooks.Add
            Set Sh2 = .Sheets(1)
            Rng.AutoFilter 20, Ms
            Sh1.Range(Sh1.Range("A1"), Rng).SpecialCells(12).Copy
            Sh2.Range("A1").PasteSpecial 8
            Sh2.Range("A1").PasteSpecial
            Rng.AutoFilter
            Application.DisplayAlerts = False
            On Error Resume Next
            .Close True, ThisWorkbook.Path & "\" & Ms & ".xlsx"
            Application.DisplayAlerts = True
        End With
        End If
    Next I
Application.ScreenUpdating = True
End Sub

vì thấy đề tài hay quá và cón vận dụng thêm được, em xin phép hỏi nhanh, nhờ anh giúp đỡ
yêu cầu cũng giống hệt chủ topic là lọc, cắt dán ra File excel mới ạ.
Nhưng khác ở chỗ:
y/c1 ---> em muốn chỉ chuột chọn 1 mã CN nào đó ( ở dòng bất kỳ, cột B ), rồi chạy code, ra 1 file excel chứa C đó.
y/c2 ---> em chỉ chuột vào 1 mã Cửa hảng nào đó ( ở dòng bất kỳ, cột C ), rồi chạy code ra 1 file excel chứa CH đó. (2y/c trong cùng 1 code )
em cám ơn ạ. (dữ lliệu là thật thực tế chỉ nhiều dòng hơn thôi ạ)

babe_nice · 13/12/15

Nguyên văn bởi hpkhuongĐã thử. Nhưng còn vướng cái chỗ làm Sao save được file, đang ở vòng lặp I nên nó không có save được. Mà vẫn Open ->chờ save = tay..... Úp lên cho quý vị giải giúp!!!

Gửi anh hpkhuong, em xin lỗi vì yêu cầu bài #23, em lại cop đoạn code anh đang chưa hoàn chỉnh chăng, có lẽ em chưa cao siêu đến mức chỉ dùng 1 vòng lặp để nhanh.
Nếu yêu cầu đơn thuần chỉ là:
- y/c1 ---> em muốn chỉ chuột chọn 1 mã CN nào đó ( ở dòng bất kỳ, cột B ), rồi chạy code, ra 1 file excel chứa C đó.
- y/c2 ---> em chỉ chuột vào 1 mã Cửa hảng nào đó ( ở dòng bất kỳ, cột C ), rồi chạy code ra 1 file excel chứa CH đó.
Chỉ với 2 yêu cầu trên thì bài toán có được giải không anh? ( em cám ơn)

babe_nice · 14/12/15

hpkhuong đã viết:

Paste code vào sheet.
Double Click vào cột B hoặc C từ dòng 3 trở đi tới dòng cuối B có dữ liệu thì code có tác dụng. (Click vào dòng trống thì code lỗi ráng chịu nhé.)

Mã:

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Rng As Range, RngF As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = ThisWorkbook.Sheets("GPE")
Set Rng = Range([B3], [B65000].End(3)).Resize(, 2)
Set RngF = Range([A2], [A65000].End(3)).Resize(, 6)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Rng) Is Nothing Then
    With Workbooks.Add
        Set Sh2 = .Sheets(1)
        RngF.AutoFilter Target.Column, Target.Value2
        Sh1.Range(Sh1.Range("A1"), RngF).SpecialCells(12).Copy
        Sh2.Range("A1").PasteSpecial xlPasteValues
        Sh2.Range("A1").PasteSpecial xlPasteFormats
        Rng.AutoFilter
        .Close True, ThisWorkbook.Path & "\" & Target.Value2 & ".xls"
    End With
End If
MsgBox "Done: Tach File xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ô, hay thiệt, em cám ơn.
chỉ có: khi mở file được tách ra hơi xoay 1 tý và có cảnh báo gì đó, nhưng ấn Yes là mở ngon.
( P/s: nếu anh có thời gian rảnh 1 tý, thì chuyển thành public sub hộ em ạ, để khi nào đang nhập tránh nhỡ tay, xin lỗi, đầu bài em nói là chạy code không rõ, em cứ nghĩ là ấn Module, anh lại nghĩ là double click sự kiện..... hix..do em)

babe_nice · 14/12/15

hpkhuong đã viết:
Thay vì phải Thêm thao tác gọi sub: Bạn chỉ cần Nhấp đúp vào đó...thì nó chạy rồi... Cái nào sướng hơn

Cám ơn anh nhiệt tình.
( em lưu thành công cụ dùng lâu dài và tùy chỉnh theo ý mình được rồi )

Cắt file Excel theo cụm (1 người xem)

Người dùng đang xem chủ đề này

Thành viên mới

Thành viên mới

Thành viên mới

File đính kèm

Ăn cùng góc phố

Thành viên gạo cội

Ăn cùng góc phố

Huyền thoại GPE

hello

Thành viên gắn bó

hello

Huyền thoại GPE

hello

hello

Chuyên gia GPE

Chuyên gia GPE

Thành viên chính thức

File đính kèm

Thành viên chính thức

File đính kèm

Thành viên chính thức

Thành viên chính thức

Đếm ngược thời gian