Muốn tách 1 sheet thành nhiều sheet theo điều kiện cột N (để kết quả mỗi nhân viên là sheef)

Liên hệ QC
L

lai120594

Thành viên mới
Tham gia
4/4/20
Bài viết
3
Được thích
0
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
 

File đính kèm

  • VBA vi du.xls
    255 KB · Đọc: 25
Sắp xếp theo thời gian sắp xếp theo bầu chọn
lai120594 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
Upvote 0
giaiphap đã viết:
Bạ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
Nhấp chuột vào đây để mở rộng...
1586163160328.pngk
Bài đã được tự động gộp:

giaiphap đã viết:
Bạ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
Nhấp chuột vào đây để mở rộng...
k được bạn ạ, các có dùng zalo k chỉ hộ mình với
 
Upvote 0
giaiphap đã viết:
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
Nhấp chuột vào đây để mở rộng...

Dữ liệu của mình khoảng 60000 dòng, mình chạy bị báo lỗi Overflow.
Bạn có thể chỉnh lại giúp mình để chạy được với dữ liệu lớn không?
 
Upvote 0
Quỳnh Như 7648 đã viết:
Dữ liệu của mình khoảng 60000 dòng, mình chạy bị báo lỗi Overflow.
Bạn có thể chỉnh lại giúp mình để chạy được với dữ liệu lớn không?
Nhấp chuột vào đây để mở rộng...
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ử.
 
Upvote 0
Quỳnh Như 7648 đã viết:
Bạn xem giúp mình nhé. Cám ơn bạn. Mình muốn tách theo cột A
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
Quỳnh Như 7648 đã viết:
Bạn xem giúp mình nhé. Cám ơn bạn. Mình muốn tách theo cột A
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
quick87 đã viết:
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
Nhấp chuột vào đây để mở rộng...

Cám ơn bạn. Mà hiện tại đang tách thành nhiều file.
Có cách nào để tách thành nhiều sheet trong cùng 1 file ko bạn?
 
Upvote 0
giaiphap đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • tachsheet.xlsm
    17.4 KB · Đọc: 14
Upvote 0
dongducnhiem đã viết:
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
Nhấp chuột vào đây để mở rộng...
Bạn thử lại code dưới nhé:
Rich (BB code): 
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
 
Upvote 0
giaiphap đã viết:
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
Nhấp chuột vào đây để mở rộng...

Cám ơn bạn
 
Upvote 0
Tôi đã tìm ra lỗi
Sửa
Rng.AutoFilter 4, Bp
Thành
Rng.AutoFilter 2, Bp
Xin cảm ơn!
 
Upvote 0
giaiphap đã viết:
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
Nhấp chuột vào đây để mở rộng...
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ới
 

File đính kèm

  • CHECK CODE.xlsx
    2.2 MB · Đọc: 4
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
112
Đọc
19K
Hongngoc710
Hongngoc710
V
  • Question
Tìm kiếm và copy giá trị từ bảng đến bảng khác
Trả lời
5
Đọc
63
BuiQuangThuan
B
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
Trả lời
12
Đọc
141
HUONGHCKT
H
O
Nhờ sửa code tự động trừ đi một giá trị trong vùng được chọn
Trả lời
5
Đọc
79
ohlexus
O
H
  • Question
Em nhờ các bác làm giúp em in và lưu lịch sử lệnh sản xuất
Trả lời
7
Đọc
211
hiv174
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom