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

[Trường Lx]

Chào các bác ạ
Em có file dữ liệu như thế này, đã có code VBA tách sheet tổng thành các sheet theo tên ở cột A. nhưng dữ liệu của em cần lấy lại ở cột F. kính mong các bác chỉnh giúp em với ạ. Em xin gửi kèm file tham khảo ạ
Em xin cám ơn!

Sub Tach_Sheets()
Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 20)
Dim Dic As Object, Key$, Ws As Worksheet, Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
Ws.Delete
End If
Next Ws
With Sheets("Sheet1")
Set Rng = .Range("A1:Y1")
Lr = .Range("A" & Rows.Count).End(xlUp).Row
Arr = .Range("A2:Y" & Lr).Value
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
Key = Arr(i, 1)
If Not Dic.exists(Key) Then
Dic.Add (Key), ""
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Key
End If
End If
Next i
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
For i = 1 To UBound(Arr)
If Arr(i, 1) = Ws.Name Then
k = k + 1
For j = 1 To 20
Res(k, j) = Arr(i, j)
Next j
End If
Next i
End If
If k Then
Rng.Copy Ws.Range("A1")
Ws.Range("A2").Resize(k, 20).Value = Res
Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
Ws.Columns("A:Y").AutoFit
k = 0
End If
Next Ws
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub

 

[snow25]

Chào các bác ạ
Em có file dữ liệu như thế này, đã có code VBA tách sheet tổng thành các sheet theo tên ở cột A. nhưng dữ liệu của em cần lấy lại ở cột F. kính mong các bác chỉnh giúp em với ạ. Em xin gửi kèm file tham khảo ạ
Em xin cám ơn!

Thử code này.

Sub Tach_Sheets()
Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 17)
Dim Dic As Object, Key$, Ws As Worksheet, Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
Ws.Delete
End If
Next Ws
With Sheets("Sheet1")
Set Rng = .Range("A1:Q1")
Lr = .Range("A" & Rows.Count).End(xlUp).Row
Arr = .Range("A2:Q" & Lr).Value
For i = 1 To UBound(Arr)
If Arr(i, 6) <> "" Then
Key = Arr(i, 6)
If Not Dic.exists(Key) Then
Dic.Add (Key), ""
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Key
End If
End If
Next i
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
For i = 1 To UBound(Arr)
If Arr(i, 6) = Ws.Name Then
k = k + 1
For j = 1 To 17
Res(k, j) = Arr(i, j)
Next j
End If
Next i
End If
If k Then
Rng.Copy Ws.Range("A1")
Ws.Range("A2").Resize(k, 17).Value = Res
Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
Ws.Columns("A:Q").AutoFit
k = 0
End If
Next Ws
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub

 

[Trường Lx]

Thử code này.

Sub Tach_Sheets()
Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 17)
Dim Dic As Object, Key$, Ws As Worksheet, Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
Ws.Delete
End If
Next Ws
With Sheets("Sheet1")
Set Rng = .Range("A1:Q1")
Lr = .Range("A" & Rows.Count).End(xlUp).Row
Arr = .Range("A2:Q" & Lr).Value
For i = 1 To UBound(Arr)
If Arr(i, 6) <> "" Then
Key = Arr(i, 6)
If Not Dic.exists(Key) Then
Dic.Add (Key), ""
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Key
End If
End If
Next i
For Each Ws In Worksheets
If Ws.Name <> "Sheet1" Then
For i = 1 To UBound(Arr)
If Arr(i, 6) = Ws.Name Then
k = k + 1
For j = 1 To 17
Res(k, j) = Arr(i, j)
Next j
End If
Next i
End If
If k Then
Rng.Copy Ws.Range("A1")
Ws.Range("A2").Resize(k, 17).Value = Res
Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
Ws.Columns("A:Q").AutoFit
k = 0
End If
Next Ws
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub

Quá tuyệt vời. Em cảm ơn bác nhiều ạ