Gửi bởi
subasatran
Có Anh/Chị nào có thể hưởng dẫn cách làm với việc tách như thế này ko ạ.
Hiện tại tách một cột được nhưng chưa biết làm tách nhiều cột. Xin cám ơn rất nhiều
Bạn tải file thật của bạn lên. Với file full là bao nhiêu sheet để còn biết mà code. Rồi tôi xem cho...
Không thể nói chung chung vậy được...là rất nhiều sheet, mà không biết sheet của bạn là bao nhiêu,...
Rồi nếu muốn làm 1 lần thì tất nhiên giữa các sheet phải đồng nhất về số cột & dữ liệu tại các cột giữa các sheet là giống nhau (đồng nhất mới làm 1 lần được), và dòng tiêu đề cũng phải đồng nhất...
Như những file ở các Topic khác của bạn tôi đã từng giúp bạn code...
Vậy nhé!
============================================
Chờ bạn phản hồi lâu quá, tôi viết luôn cho bạn với dữ liệu trên file #1
============================================
Chú ý là sheet ví dụ "Structure" của bạn dữ liệu bị lệch 1 dòng so với 2 sheet chính. Cho nên muốn chạy code chính xác phải chèn thêm dòng số 2, đẩy dữ liệu bắt đầu từ dòng thứ 3 cho đồng nhất rồi chạy code sau...
P/s: Xóa luôn mấy cái Range bạn đang Merge để mô tả vấn đề trước khi chạy code nha (chỉ để lại dữ liệu ví dụ)
Tôi chỉ viết code phần tách file cho bạn, còn phần email thì bạn tự search trên diễn đàn ấy!
Mã:
Option Explicit
Public Sub GPE()
Dim Dic As Object, Tmp As String, Arr, Path, Rng As Range
Dim I As Long, J As Long, K As Long, WbMain As Workbook, Ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Path = ActiveWorkbook.Path
Set Dic = CreateObject("Scripting.Dictionary")
For J = 1 To 5
For Each Ws In WbMain.Worksheets
Set Rng = Ws.Range("A2", Ws.Range("A65000").End(3)).Resize(, 8)
Arr = Ws.Range("A3", Ws.Range("A65000").End(3)).Resize(, 5).Value
For I = 1 To UBound(Arr)
If Arr(I, J) <> Empty Then
Tmp = Arr(I, J)
If Not Dic.Exists(Tmp) Then
K = K + 1
Dic.Add Tmp, K
With Workbooks.Add
Rng.AutoFilter J, Tmp
Ws.Range("A1", Rng).SpecialCells(12).Copy
.Sheets(1).Name = Ws.Name
.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
.Sheets(1).Range("A1").PasteSpecial xlPasteFormats
Rng.AutoFilter
.Close True, ThisWorkbook.Path & "\" & Tmp & "_" & Ws.Name & ".xlsx"
End With
End If
End If
Next I
Ws.AutoFilterMode = False
Dic.RemoveAll
Next Ws
Next J
Set Dic = Nothing
MsgBox "Da Tach Xong!"
Application.SheetsInNewWorkbook = 3
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub