Tách dữ liệu ra nhiều file

tuanxitin

Thành viên mới
Tham gia ngày
5 Tháng sáu 2016
Bài viết
28
Được thích
2
Điểm
165
Tuổi
33
Dear anh/chị cao nhân,

nhờ anh/chị xem giúp em file bị lỗi gì đính kèm giúp em
Em có 1 file tổng gồm nhiều đơn vị, mỗi đơn vị có nhiều dòng khác nhau, từ file tổng đó, e tách ra mỗi đơn vị là 1 file excel, với tên file là tên đơn vị đó.
Em viết code k biết lỗi gì mà k chạy được
nhờ anh/chị xem giúp em

Cảm ơn anh/chị
 

File đính kèm

phuocam

Thành viên mới
Tham gia ngày
16 Tháng năm 2013
Bài viết
2,797
Được thích
3,898
Điểm
560
Dear anh/chị cao nhân,

nhờ anh/chị xem giúp em file bị lỗi gì đính kèm giúp em
Em có 1 file tổng gồm nhiều đơn vị, mỗi đơn vị có nhiều dòng khác nhau,
từ file tổng đó, e tách ra mỗi đơn vị là 1 file excel, với tên file là tên đơn vị đó.
Em viết code k biết lỗi gì mà k chạy được
nhờ anh/chị xem giúp em

Cảm ơn anh/chị
Mã trong file là: Sub tach_sheet_TH_thanh_nhieu_sheet()
Bạn viết mã "Tách sheet" hay "Tách file"?
 

tuanxitin

Thành viên mới
Tham gia ngày
5 Tháng sáu 2016
Bài viết
28
Được thích
2
Điểm
165
Tuổi
33
em mới tập tành viết code, nên mới nhờ anh/chị cao nhân hỗ trợ giúp em.
Anh xem fix lỗi giúp em được không ạ
 

phuocam

Thành viên mới
Tham gia ngày
16 Tháng năm 2013
Bài viết
2,797
Được thích
3,898
Điểm
560
Thử code này:
Mã:
Sub tach_sheet_TH_thanh_nhieu_sheet()

    Dim lr As Long
    Dim dic As Object
    Dim rng As Range, cel As Range
    Dim Ws As Worksheet
    
Set dic = CreateObject("Scripting.Dictionary")
Set Ws = Sheets("form")
lr = Ws.Range("c" & Rows.Count).End(xlUp).Row
Set rng = Ws.Range("c1:n" & lr)
Ws.AutoFilterMode = False
For Each cel In Ws.Range("C2:C" & lr)
    
    If Not dic.exists(cel.Value) Then
        rng.AutoFilter field:=1, Criteria1:=cel.Value
        If Not WsExit(cel.Value) Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = cel.Value
        Else
            Sheets(cel.Value).Move after:=Worksheets(Worksheets.Count)
            Sheets(cel.Value).Cells.ClearContents
        End If
        rng.SpecialCells(xlCellTypeVisible).Copy Sheets(cel.Value).Cells(1, 1)
        Sheets(cel.Value).UsedRange.EntireColumn.AutoFit
        dic.Add (cel.Value), ""
        rng.AutoFilter
    End If
Next cel

End Sub
 
Top Bottom