[HELP] - Tách dữ liệu ra nhiều file theo cấp quản lý. (1 người xem)

[subasatran]

Rất cảm ơn hpkhuong nhiều.
Giả sử bây giờ có thêm một sheet vd2 cũng với trường hợp tương tự thì sửa code ra sao vậy ?
Mình thử sửa lại code nhưng nó lại tách được sheet vd2 thôi, cón sheet vd1 thì ko được.
chắc do ko biết sửa vỏng lặp.
Nhờ giúp thêm xíu nữa. Cảm ơn rất nhiều.

Option Explicit
Public Sub GPE()
Dim I As Long, J As Long, K As Long, ShMain1 As Worksheet, Sh1 As Worksheet, ShMain2 As Worksheet, Sh2 As Worksheet
Dim Arr, dArr, Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range
Dim Dic As Object, Tem As String, KhV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Sheets("RD").Range("B25", Sheets("RD").Range("C25").End(4)).Value
ReDim dArr(1 To UBound(Arr), 1 To 1)
Set ShMain1 = ThisWorkbook.Sheets("Vd1")
Set ShMain2 = ThisWorkbook.Sheets("Vd2")
Set Rng1 = ShMain1.Range("A4", ShMain1.Range("A65000").End(3)).Resize(, 12)
Set Rng2 = ShMain1.Range("N4", ShMain1.Range("N65000").End(3)).Resize(, 21)
Set Rng3 = ShMain2.Range("A3", ShMain2.Range("A65000").End(3)).Resize(, 8)
Set Rng4 = ShMain2.Range("J3", ShMain2.Range("J65000").End(3)).Resize(, 8)
Set Rng5 = ShMain2.Range("S3", ShMain2.Range("S65000").End(3)).Resize(, 7)
Set Dic = CreateObject("Scripting.Dictionary")
K = 0
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Not Dic.exists(Tem) Then
Dic.Add Tem, ""
K = 0
For J = 1 To UBound(Arr)
If Arr(J, 1) = Tem Then
K = K + 1
dArr(K, 1) = Arr(J, 2)
End If
Next J
Sheets("RD").Range("D251000").ClearContents
Sheets("RD").Range("D25").Resize(K).Value = dArr
KhV = Application.Transpose(Sheets("RD").Range("D25", Sheets("RD").Range("D25").End(4)))
End If
'--------------------------------------------------------------
With Workbooks.Add
Set Sh1 = .Sheets(1)
Rng1.AutoFilter 1, KhV, 7
ShMain1.Range(ShMain1.Range("A1"), Rng1).SpecialCells(12).Copy
Sh1.Range("A1").PasteSpecial xlPasteValues
Sh1.Range("A1").PasteSpecial xlPasteFormats
Rng1.AutoFilter
'----------------------------------------------------------
Rng2.AutoFilter 1, KhV, 7
ShMain1.Range(ShMain1.Range("N1"), Rng2).SpecialCells(12).Copy
Sh1.Range("N1").PasteSpecial xlPasteValues
Sh1.Range("N1").PasteSpecial xlPasteFormats
Rng2.AutoFilter
'----------------------------------------------------------
.Close True, ThisWorkbook.Path & "" & Tem & ".xlsx"
End With
With Workbooks.Add
Set Sh2 = .Sheets(2)
Rng3.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("A1"), Rng3).SpecialCells(12).Copy
Sh2.Range("A1").PasteSpecial xlPasteValues
Sh2.Range("A1").PasteSpecial xlPasteFormats
Rng3.AutoFilter
'----------------------------------------------------------
Rng4.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("J1"), Rng4).SpecialCells(12).Copy
Sh2.Range("J1").PasteSpecial xlPasteValues
Sh2.Range("J1").PasteSpecial xlPasteFormats
Rng4.AutoFilter
'----------------------------------------------------------
Rng5.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("S1"), Rng5).SpecialCells(12).Copy
Sh2.Range("S1").PasteSpecial xlPasteValues
Sh2.Range("S1").PasteSpecial xlPasteFormats
Rng5.AutoFilter
'----------------------------------------------------------
.Close True, ThisWorkbook.Path & "" & Tem & ".xlsx"
End With

Next I
Sheets("RD").Range("D251000").ClearContents
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[subasatran]

Cám ơn rất nhiều.
Sửa code tách được 2 file rồi. Nhưng chưa hiểu code cho lắm.

Option ExplicitPublic Sub GPE()
Dim I As Long, J As Long, K As Long, ShMain1 As Worksheet, Sh1 As Worksheet, ShMain2 As Worksheet, Sh2 As Worksheet
Dim Arr, dArr, Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range
Dim Dic As Object, Tem As String, KhV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Sheets("RD").Range("B25", Sheets("RD").Range("C25").End(4)).Value
ReDim dArr(1 To UBound(Arr), 1 To 1)
Set ShMain1 = ThisWorkbook.Sheets("Vd1")
Set ShMain2 = ThisWorkbook.Sheets("Vd2")
Set Rng1 = ShMain1.Range("A4", ShMain1.Range("A65000").End(3)).Resize(, 12)
Set Rng2 = ShMain1.Range("N4", ShMain1.Range("N65000").End(3)).Resize(, 21)
Set Rng3 = ShMain2.Range("A3", ShMain2.Range("A65000").End(3)).Resize(, 8)
Set Rng4 = ShMain2.Range("J3", ShMain2.Range("J65000").End(3)).Resize(, 8)
Set Rng5 = ShMain2.Range("S3", ShMain2.Range("S65000").End(3)).Resize(, 7)
Set Dic = CreateObject("Scripting.Dictionary")
K = 0
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Not Dic.exists(Tem) Then
Dic.Add Tem, ""
K = 0
For J = 1 To UBound(Arr)
If Arr(J, 1) = Tem Then
K = K + 1
dArr(K, 1) = Arr(J, 2)
End If
Next J
Sheets("RD").Range("D251000").ClearContents
Sheets("RD").Range("D25").Resize(K).Value = dArr
KhV = Application.Transpose(Sheets("RD").Range("D25", Sheets("RD").Range("D25").End(4)))
End If
'--------------------------------------------------------------
With Workbooks.Add
Set Sh1 = .Sheets(1)
Set Sh2 = .Sheets(2)
Rng1.AutoFilter 1, KhV, 7
ShMain1.Range(ShMain1.Range("A1"), Rng1).SpecialCells(12).Copy
Sh1.Range("A1").PasteSpecial xlPasteValues
Sh1.Range("A1").PasteSpecial xlPasteFormats
Rng1.AutoFilter
'----------------------------------------------------------
Rng2.AutoFilter 1, KhV, 7
ShMain1.Range(ShMain1.Range("N1"), Rng2).SpecialCells(12).Copy
Sh1.Range("N1").PasteSpecial xlPasteValues
Sh1.Range("N1").PasteSpecial xlPasteFormats
Rng2.AutoFilter
'----------------------------------------------------------
Rng3.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("A1"), Rng3).SpecialCells(12).Copy
Sh2.Range("A1").PasteSpecial xlPasteValues
Sh2.Range("A1").PasteSpecial xlPasteFormats
Rng3.AutoFilter
'----------------------------------------------------------
Rng4.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("J1"), Rng4).SpecialCells(12).Copy
Sh2.Range("J1").PasteSpecial xlPasteValues
Sh2.Range("J1").PasteSpecial xlPasteFormats
Rng4.AutoFilter
'----------------------------------------------------------
Rng5.AutoFilter 1, KhV, 7
ShMain2.Range(ShMain2.Range("S1"), Rng5).SpecialCells(12).Copy
Sh2.Range("S1").PasteSpecial xlPasteValues
Sh2.Range("S1").PasteSpecial xlPasteFormats
Rng5.AutoFilter
'----------------------------------------------------------
.Close True, ThisWorkbook.Path & "" & Tem & ".xlsx"
End With
Next I
Sheets("RD").Range("D251000").ClearContents
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[subasatran]

Kính gởi A/C GPE,
Nhờ mọi người sửa giúp đoạn code VBA tách file trong file đính kèm giúp.
Nó chỉ chạy được phần header. phần data ko thể hiện và vòng lặp không dừng.
Nhờ A/C nào biết lỗi sửa lỗi giúp.
Tách file gồm 4 sheet theo cột BL. Cám ơn anh chị.

 

[subasatran]

Tất cả các Sheet đều có cột BL mà (Sheet 2 và 3 không có dữ liệu đến cột BL nhưng cột BL vẫn có dữ liệu).
Mình muốn tách căn cứ vào cột này để tách dữ liệu ra.
Sau khi tách file mới thì dữ liệu từ cột này trở về sau sẽ bị xóa đi.
Tất cả 4 sheet thì cột BL mình có để mã RH. Căn cứ vào cột này để tách ra cho mỗi RH.
Do tay ngang không hiểu kỹ về code nên resize đoán đoán từ cột A đến cột BL là 63 cột nên để 63.

p/s : "Hình như bạn chưa thấy Quan Tài Chưa Đổ Lệ ah". Chưa hiểu nguyên nhân về câu này cho lắm.
Nếu có gì sơ xót, thông cảm giúp. Thanks

 

[subasatran]

Cám ơn hpkhuong rất nhiều.
Công nhận ngưỡng mộ thật đấy.

 

[themoon2087]

Chào bác hpkhuong, bác giúp em code tách file này với ạ:
- Tách ra các file khác nhau theo "Khu vực" có đầy đủ 5 sheets.
Cảm ơn bác nhiều

 

[themoon2087]

Sau này có thêm lớp thì chỉ cần thêm tên Sheet là được bác nhỉ? Cảm ơn bác nhiều lắm!!!