Bạn dùng thử code này.Nhờ a chị hỗ trợ em với em có file này muốn tách 1 sheet thành nhiều sheet theo cột N là mỗi nhân viên là 1 sheet
Public Sub GPE()
Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook
Dim Dic, Tem As String, Bp As String, Rng As Range, iRow%
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
With Wb.Sheets(1)
iRow = .[A65000].End(3).Row
Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14)
Set Dic = CreateObject("scripting.dictionary")
Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 14)
If Tem <> Empty And Not Dic.exists(Tem) Then
Dic.Add Tem, ""
Bp = Tem
Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count))
Rng.AutoFilter 14, Bp
.Range("A1", Rng).SpecialCells(12).Copy
With Wh
.[A1].PasteSpecial xlPasteValues
.[A1].PasteSpecial xlPasteFormats
.Rows("1:" & iRow).RowHeight = 15
.Columns("A").Resize(, 14).AutoFit
.Name = Bp
End With
End If
Next I
Set Dic = Nothing
End With
Application.CutCopyMode = False
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
kBạn dùng thử code này.
Mã:Public Sub GPE() Dim I As Long, Arr, Path As String, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook Path = ThisWorkbook.Path With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value For I = 1 To UBound(Arr) Tem = Arr(I, 14) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 14, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 14).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
k được bạn ạ, các có dùng zalo k chỉ hộ mình vớiBạn dùng thử code này.
Mã:Public Sub GPE() Dim I As Long, Arr, Path As String, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook Path = ThisWorkbook.Path With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value For I = 1 To UBound(Arr) Tem = Arr(I, 14) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 14, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 14).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
Bạn dùng thử code này.
Mã:Public Sub GPE() Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value For I = 1 To UBound(Arr) Tem = Arr(I, 14) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 14, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 14).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
Mình chưa thử dữ liệu lớn bao giờ, bạn có thể đưa cái file đó lên đây mình xem thử.
Bạn dùng thử code sau đỡ nhé:Bạn xem giúp mình nhé. Cám ơn bạn. Mình muốn tách theo cột A
Option Explicit
Sub zaq()
Dim Rng As Range, endR As Long
With Application
.DisplayAlerts = False
.ScreenUpdating = False
With ActiveSheet
endR = .Range("A650000").End(xlUp).Row
.Range("A2:A" & endR).Copy Range("P2")
.Range("P2:P" & endR).RemoveDuplicates 1, xlNo
.Range("A1").CurrentRegion.AutoFilter
For Each Rng In .Range("P2:P" & .Range("P2").End(xlDown).Row - 1)
With .Range("A1").CurrentRegion
.AutoFilter 1, Rng.Value
.Copy
End With
Workbooks.Add: ActiveSheet.Paste
ActiveSheet.Columns("A:N").AutoFit
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & Rng, FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next
.Range("A1").CurrentRegion.AutoFilter
End With
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Done"
End Sub
Sửa code lại thế này.Bạn xem giúp mình nhé. Cám ơn bạn. Mình muốn tách theo cột A
Public Sub GPE()
Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook
Dim Dic, Tem As String, Bp As String, Rng As Range, iRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Wb = ThisWorkbook
With Wb.Sheets(1)
iRow = .Range("A65000").End(xlUp).Row
Set Rng = .Range("A1:A" & iRow).Resize(, 9)
Set Dic = CreateObject("scripting.dictionary")
Arr = .Range("A2", .[A65000].End(3)).Resize(, 9).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Tem <> Empty And Not Dic.exists(Tem) Then
Dic.Add Tem, ""
Bp = Tem
Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count))
Rng.AutoFilter 1, Bp
.Range("A1", Rng).SpecialCells(12).Copy
With Wh
.[A1].PasteSpecial xlPasteValues
.[A1].PasteSpecial xlPasteFormats
.Rows("1:" & iRow).RowHeight = 15
.Columns("A").Resize(, 9).AutoFit
.Name = Bp
End With
End If
Next I
Set Dic = Nothing
End With
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
Bạn dùng thử code sau đỡ nhé:
PHP:Option Explicit Sub zaq() Dim Rng As Range, endR As Long With Application .DisplayAlerts = False .ScreenUpdating = False With ActiveSheet endR = .Range("A650000").End(xlUp).Row .Range("A2:A" & endR).Copy Range("P2") .Range("P2:P" & endR).RemoveDuplicates 1, xlNo .Range("A1").CurrentRegion.AutoFilter For Each Rng In .Range("P2:P" & .Range("P2").End(xlDown).Row - 1) With .Range("A1").CurrentRegion .AutoFilter 1, Rng.Value .Copy End With Workbooks.Add: ActiveSheet.Paste ActiveSheet.Columns("A:N").AutoFit With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Rng, FileFormat:=xlOpenXMLWorkbook .Close End With Next .Range("A1").CurrentRegion.AutoFilter End With .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "Done" End Sub
Tôi có copy code trên và sửa cho file của tôi nhưng vẫn không đúng, nhờ bạn hỗ trợBạn dùng thử code này.
Mã:Public Sub GPE() Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value For I = 1 To UBound(Arr) Tem = Arr(I, 14) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 14, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 14).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
Public Sub GPE()
Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook
Dim Dic, Tem As String, Bp As String, Rng As Range, iRow%
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
With Wb.Sheets(1)
iRow = .[A65000].End(3).Row
Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 4)
Set Dic = CreateObject("scripting.dictionary")
Arr = .Range("A2", .[A65000].End(3)).Resize(, 4).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 2)
If Tem <> Empty And Not Dic.exists(Tem) Then
Dic.Add Tem, ""
Bp = Tem
Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count))
Rng.AutoFilter 4, Bp
.Range("A1", Rng).SpecialCells(12).Copy
With Wh
.[A1].PasteSpecial xlPasteValues
.[A1].PasteSpecial xlPasteFormats
.Rows("1:" & iRow).RowHeight = 15
.Columns("A").Resize(, 4).AutoFit
.Name = Bp
End With
End If
Next I
Set Dic = Nothing
End With
Application.CutCopyMode = False
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
Bạn thử lại code dưới nhé:Tôi có copy code trên và sửa cho file của tôi nhưng vẫn không đúng, nhờ bạn hỗ trợ
Cái tôi muốn tách là mặt hàng ở cột B
Cảm ơn bạn
Mã:Public Sub GPE() Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 4) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 4).Value For I = 1 To UBound(Arr) Tem = Arr(I, 2) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 4, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 4).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
Public Sub GPE()
Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook
Dim Dic, Tem As String, Bp As String, Rng As Range, iRow%
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
With Wb.Sheets(1)
iRow = .[A65000].End(3).Row
Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 4)
Set Dic = CreateObject("scripting.dictionary")
Arr = .Range("A2", .[A65000].End(3)).Resize(, 4).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 2)
If Tem <> Empty And Not Dic.exists(Tem) Then
Dic.Add Tem, ""
Bp = Tem
Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count))
Rng.AutoFilter 2, Bp
.Range("A1", Rng).SpecialCells(12).Copy
With Wh
.[A1].PasteSpecial xlPasteValues
.[A1].PasteSpecial xlPasteFormats
.Rows("1:" & iRow).RowHeight = 15
.Columns("A").Resize(, 4).AutoFit
.Name = Bp
End With
End If
Next I
Set Dic = Nothing
End With
Application.CutCopyMode = False
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
Sửa code lại thế này.
Mã:Public Sub GPE() Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow As Long Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set Wb = ThisWorkbook With Wb.Sheets(1) iRow = .Range("A65000").End(xlUp).Row Set Rng = .Range("A1:A" & iRow).Resize(, 9) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 9).Value For I = 1 To UBound(Arr) Tem = Arr(I, 1) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 1, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 9).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub
Cảm ơn bạn nhiềuThử 1 cách khác.
Mình sử dụng cho 1 file khác thì lại không được, bạn xem lại giúp mình vớiBạn dùng thử code này.
Mã:Public Sub GPE() Dim I As Long, Arr, Wh As Worksheet, Wb As Workbook Dim Dic, Tem As String, Bp As String, Rng As Range, iRow% Application.DisplayAlerts = False Application.ScreenUpdating = False Set Wb = ThisWorkbook With Wb.Sheets(1) iRow = .[A65000].End(3).Row Set Rng = .Range("A1", .[A65000].End(3)).Resize(, 14) Set Dic = CreateObject("scripting.dictionary") Arr = .Range("A2", .[A65000].End(3)).Resize(, 14).Value For I = 1 To UBound(Arr) Tem = Arr(I, 14) If Tem <> Empty And Not Dic.exists(Tem) Then Dic.Add Tem, "" Bp = Tem Set Wh = Wb.Sheets.Add(After:=Sheets(Wb.Worksheets.Count)) Rng.AutoFilter 14, Bp .Range("A1", Rng).SpecialCells(12).Copy With Wh .[A1].PasteSpecial xlPasteValues .[A1].PasteSpecial xlPasteFormats .Rows("1:" & iRow).RowHeight = 15 .Columns("A").Resize(, 14).AutoFit .Name = Bp End With End If Next I Set Dic = Nothing End With Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub