Nhờ giúp đỡ code VBA tách 1 sheet thành nhiều sheet

[curet]

Chào các bạn.
Mình có file dữ liệu như thế này, nhờ các bạn giúp đỡ code VBA tách sheet tổng thành các sheet có tên ở cột F:Q.
Xin cám ơn!

 

[snow25]

Chào các bạn.
Mình có file dữ liệu như thế này, nhờ các bạn giúp đỡ code VBA tách sheet tổng thành các sheet có tên ở cột F:Q.
Xin cám ơn!

Bạn thử code.Mình thêm 1 sheets mẫu để copy.Bỏ luôn các cột bạn dùng công thức để tách.

Sub tach()
     Application.ScreenUpdating = False
     Application.EnableEvents = False
     Application.DisplayAlerts = False
   Dim i As Long, lr As Long, dic As Object, sh As Worksheet, T, s As String, data, arr, k As Integer, j As Integer, dk As String
   Set dic = CreateObject("scripting.dictionary")
   For Each sh In ThisWorkbook.Worksheets
       If sh.Name <> "TNM" And sh.Name <> "Mau" Then
          sh.Delete
       End If
   Next
   With Sheets("TNM")
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       arr = .Range("B3:E" & lr).Value
       For i = 1 To UBound(arr)
           T = Split("," & arr(i, 3), ",")
           For j = 1 To UBound(T)
               If j = 1 Then dk = Right(T(j), 3) Else dk = T(j)
               If Not dic.exists(dk) Then
                  dic.Add dk, "#" & i
               Else
                  s = dic.Item(dk)
                  If InStr(s & "#", "#" & i & "#") = 0 Then
                     s = s & "#" & i
                     dic.Item(dk) = s
                  End If
               End If
           Next j
       Next i
  End With
       data = dic.keys
       For k = 0 To UBound(data)
           dk = data(k)
           T = Split(dic.Item(dk), "#")
           ReDim kq(1 To UBound(arr), 1 To 5)
           For i = 1 To UBound(T)
               kq(i, 1) = i
               kq(i, 2) = arr(T(i), 1)
               kq(i, 3) = arr(T(i), 2)
               kq(i, 4) = arr(T(i), 3)
               kq(i, 5) = arr(T(i), 4)
           Next i
           Sheets("Mau").Copy After:=Sheets(Sheets.Count)
           Set sh = ActiveSheet
           sh.Name = dk
           sh.Range("A2:E2").Resize(i - 1).Value = kq
      Next k
     Set dic = Nothing
     Application.ScreenUpdating = True
     Application.EnableEvents = True
     Application.DisplayAlerts = True
End Sub

 

[curet]

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

 

[curet]

Mình đã tham khảo code VBA của bạn viết.
Chân thành cám ơn bạn.