Tách sheet và xóa sheet chỉ định ,giữ nguyên các sheet còn lại (1 người xem)

Ngocminh19 · 14/11/25

Xin chào
Nhờ anh chị và mọi người giúp em viêt code tách các sheet "Purchase" ra thành nhiều sheet,dựa trên cột A tên tháng
Em có để file đính kèm.Mọi người giúp em với
1. Kết quả Mong muốn tên sheet "Purchase_08.2025,Purchase_09.2025,.....
2. Giữ nguyên format,cột ẩn,định dạng theo sheet gôc
3. Khi tách sheet "Purchase",ra các sheet con bên cạnh ,các sheet không liên quan vẫn để nguyên
4. Viet giúp em 1 chương trình xóa chỉ xóa các sheet con tách lúc trên và không xóa các sheet còn lại ạ

em cảm ơn!

Maika8008 · 15/11/25

Chắc đang nghỉ cuối tuần nên thấy chẳng ai trả lời
Nhưng chủ thớt phải có file cho người ta giúp chứ.

DeTong · 15/11/25

Ngâm cứu đoạn code sau :

Mã:

Sub DeleteAllExceptSpecificSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "DanhSach" And ws.Name <> "All" Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
End Sub

Ngocminh19 · 15/11/25

Maika8008 đã viết:
Chắc đang nghỉ cuối tuần nên thấy chẳng ai trả lời
Nhưng chủ thớt phải có file cho người ta giúp chứ.

Cảm ơn anh đã nhắc nhở
Do file nặng > 3MB. Em update nên thấy có cảnh báo em nghĩ được rồi
Em xin cập nhật lại,anh xem và hỗ trợ em với ạ

Maika8008 · 15/11/25

Ngocminh19 đã viết:
Cảm ơn anh đã nhắc nhở
Do file nặng > 3MB. Em update nên thấy có cảnh báo em nghĩ được rồi
Em xin cập nhật lại,anh xem và hỗ trợ em với ạ

Trước tiên tách sheet đã:

Rich (BB code):

Sub TachSheet()
Dim arr, aData, i&, d&
Dim Ws As Worksheet, Rng As Range

    aData = Sheets("Purchase").Range("A13:A" & Sheets("Purchase").Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim arr(1 To 13)
    For i = 2 To UBound(aData)
        If aData(i, 1) <> aData(i - 1, 1) Then
            d = d + 1: arr(d) = i + 12
        End If
    Next
    d = d + 1: arr(d) = i + 12
    ReDim Preserve arr(1 To d)
    d = 0
    For i = 1 To UBound(arr) - 1
        d = d + 1
        Sheets("Purchase").Copy Before:=Sheets(d + 2)
        Set Ws = Sheets(d + 2)
        Ws.Name = "Purchase" & "_" & Left(aData(arr(i) - 12, 1), 3) & "." & Right(aData(arr(i) - 12, 1), 4)
        If i > 1 Then
            Set Rng = Ws.Range("A" & arr(1) & ":A" & arr(i) - 1)
            Set Rng = Union(Rng, Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1))
        Else
            Set Rng = Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1)
        End If
        Rng.EntireRow.Delete xlUp
    Next
    
End Sub

HUONGHCKT · 15/11/25

Ngocminh19 đã viết:
Xin chào
Nhờ anh chị và mọi người giúp em viêt code tách các sheet "Purchase" ra thành nhiều sheet,dựa trên cột A tên tháng
Em có để file đính kèm.Mọi người giúp em với
1. Kết quả Mong muốn tên sheet "Purchase_08.2025,Purchase_09.2025,.....
2. Giữ nguyên format,cột ẩn,định dạng theo sheet gôc
3. Khi tách sheet "Purchase",ra các sheet con bên cạnh ,các sheet không liên quan vẫn để nguyên
4. Viet giúp em 1 chương trình xóa chỉ xóa các sheet con tách lúc trên và không xóa các sheet còn lại ạ

em cảm ơn!
View attachment 310334

Góp vui.
Bạn chủ thớt Tham khảo

Mã:

Option Explicit

Sub TachSheet()

Dim i&, j&, Lr&, R&, n&, k&
Dim Arr(), Rng(), KQ(), S
Dim Dic As Object, Key
Dim ws As Worksheet, Sh As Worksheet
Dim wsName$
Set Sh = Sheets("Purchase")
    Lr = Sh.Cells(1000000, 1).End(xlUp).Row
    Arr = Sh.Range("A14:AR" & Lr).Value
    R = UBound(Arr)

Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = Arr(i, 1)
    If Not Dic.Exists(Key) Then Dic(Key) = i Else Dic(Key) = Dic(Key) & "," & i
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), ",")
    ReDim KQ(1 To UBound(Arr), 1 To UBound(Arr, 2) + 1)
    n = 0
    For j = LBound(S) To UBound(S)
        n = n + 1: KQ(n, 1) = n
        For k = 2 To UBound(Arr, 2)
            KQ(n, k) = Arr(S(j), k)
        Next k
    Next j
    On Error Resume Next
    wsName = "Purchase_" & Key
    If CBool(Len(Worksheets(wsName).Name) > 0) = False Then
        Sheets.Add After:=Sheets(Sheets.Count)
        Set ws = ActiveSheet
        ws.Name = wsName
        Sh.Rows("12:13").Copy
    ws.[A12].Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
      
        ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
    Else
        If MsgBox("Sheets " & wsName & " da có. Ban có muôn ghi de không?", vbCritical + vbYesNo, "THÔNG BÁO") = vbYes Then
            ws.[A14].Resize(100000, UBound(Arr, 2)).ClearContents
            ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
        End If
    End If
Next Key
Set Dic = Nothing
MsgBox "Thành công"
End Sub

Maika8008 · 16/11/25

Ngocminh19 đã viết:
Xin chào
...
4. Viet giúp em 1 chương trình xóa chỉ xóa các sheet con tách lúc trên và không xóa các sheet còn lại ạ

em cảm ơn!

Xoá các sheet đã tách:

Rich (BB code):

Sub XoaSheet()
Dim Ws As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name Like "Purchase_*" Then Ws.Delete
    Next
    Application.DisplayAlerts = True
End Sub

DeTong · 16/11/25

Có trường hợp nào ScreenUpdating mác đinh trả về True không ạ !

Maika8008 · 16/11/25

DeTong đã viết:
Có trường hợp nào ScreenUpdating mác đinh trả về True không ạ !

Tôi thấy ở Excel không đặt True cũng không sao cả nên bỏ luôn cho gọn (hình như mặc định chạy code xong là trả về True). Tuy nhiên bên Word thì không như vậy, không đặt True là nó đứng yên luôn.

Hoàng Tuấn 868 · 16/11/25

Maika8008 đã viết:
Tôi thấy ở Excel không đặt True cũng không sao cả nên bỏ luôn cho gọn (hình như mặc định chạy code xong là trả về True). Tuy nhiên bên Word thì không như vậy, không đặt True là nó đứng yên luôn.

Nếu không đặt lại ScreenUpdating = True thì nó không tự động trả về True đâu anh ạ.

Maika8008 · 16/11/25

Hoàng Tuấn 868 đã viết:
Nếu không đặt lại ScreenUpdating = True thì nó không tự động trả về True đâu anh ạ.

Bạn thử bằng 2 sub Tách và Xoá của tôi là thấy ngay mà. Tôi chạy sub Xoá mà không trả Updating về True rồi sau đó chạy sub Tách mà không đặt lại False thì thì màn hình vẫn cứ nháy nháy.

Ngocminh19 · 16/11/25

cảm ơn anh đã giúp đỡ
Em thấy các tháng đúng,chỉ có tháng Nov.2025
Dữ liệu em lọc là cột AI : 47734
Nhưng khi tách trong sheet tháng 11 : 43511
Thiếu 1 giá trị ạ. Anh xem giúp em với ạ

Maika8008 đã viết:

Trước tiên tách sheet đã:

Rich (BB code):

Sub TachSheet()
Dim arr, aData, i&, d&
Dim Ws As Worksheet, Rng As Range

    aData = Sheets("Purchase").Range("A13:A" & Sheets("Purchase").Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim arr(1 To 13)
    For i = 2 To UBound(aData)
        If aData(i, 1) <> aData(i - 1, 1) Then
            d = d + 1: arr(d) = i + 12
        End If
    Next
    d = d + 1: arr(d) = i + 12
    ReDim Preserve arr(1 To d)
    d = 0
    For i = 1 To UBound(arr) - 1
        d = d + 1
        Sheets("Purchase").Copy Before:=Sheets(d + 2)
        Set Ws = Sheets(d + 2)
        Ws.Name = "Purchase" & "_" & Left(aData(arr(i) - 12, 1), 3) & "." & Right(aData(arr(i) - 12, 1), 4)
        If i > 1 Then
            Set Rng = Ws.Range("A" & arr(1) & ":A" & arr(i) - 1)
            Set Rng = Union(Rng, Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1))
        Else
            Set Rng = Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1)
        End If
        Rng.EntireRow.Delete xlUp
    Next
  
End Sub

Rich (BB code):

Bài đã được tự động gộp: 16/11/25

HUONGHCKT đã viết:

Góp vui.
Bạn chủ thớt Tham khảo

Mã:

Option Explicit

Sub TachSheet()

Dim i&, j&, Lr&, R&, n&, k&
Dim Arr(), Rng(), KQ(), S
Dim Dic As Object, Key
Dim ws As Worksheet, Sh As Worksheet
Dim wsName$
Set Sh = Sheets("Purchase")
    Lr = Sh.Cells(1000000, 1).End(xlUp).Row
    Arr = Sh.Range("A14:AR" & Lr).Value
    R = UBound(Arr)

Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = Arr(i, 1)
    If Not Dic.Exists(Key) Then Dic(Key) = i Else Dic(Key) = Dic(Key) & "," & i
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), ",")
    ReDim KQ(1 To UBound(Arr), 1 To UBound(Arr, 2) + 1)
    n = 0
    For j = LBound(S) To UBound(S)
        n = n + 1: KQ(n, 1) = n
        For k = 2 To UBound(Arr, 2)
            KQ(n, k) = Arr(S(j), k)
        Next k
    Next j
    On Error Resume Next
    wsName = "Purchase_" & Key
    If CBool(Len(Worksheets(wsName).Name) > 0) = False Then
        Sheets.Add After:=Sheets(Sheets.Count)
        Set ws = ActiveSheet
        ws.Name = wsName
        Sh.Rows("12:13").Copy
    ws.[A12].Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
     
        ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
    Else
        If MsgBox("Sheets " & wsName & " da có. Ban có muôn ghi de không?", vbCritical + vbYesNo, "THÔNG BÁO") = vbYes Then
            ws.[A14].Resize(100000, UBound(Arr, 2)).ClearContents
            ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
        End If
    End If
Next Key
Set Dic = Nothing
MsgBox "Thành công"
End Sub

Em cảm ơn anh giúp đỡ,code chạy kết quả đúng rồi ạ

Bài đã được tự động gộp: 16/11/25

HUONGHCKT đã viết:

Góp vui.
Bạn chủ thớt Tham khảo

Mã:

Option Explicit

Sub TachSheet()

Dim i&, j&, Lr&, R&, n&, k&
Dim Arr(), Rng(), KQ(), S
Dim Dic As Object, Key
Dim ws As Worksheet, Sh As Worksheet
Dim wsName$
Set Sh = Sheets("Purchase")
    Lr = Sh.Cells(1000000, 1).End(xlUp).Row
    Arr = Sh.Range("A14:AR" & Lr).Value
    R = UBound(Arr)

Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = Arr(i, 1)
    If Not Dic.Exists(Key) Then Dic(Key) = i Else Dic(Key) = Dic(Key) & "," & i
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), ",")
    ReDim KQ(1 To UBound(Arr), 1 To UBound(Arr, 2) + 1)
    n = 0
    For j = LBound(S) To UBound(S)
        n = n + 1: KQ(n, 1) = n
        For k = 2 To UBound(Arr, 2)
            KQ(n, k) = Arr(S(j), k)
        Next k
    Next j
    On Error Resume Next
    wsName = "Purchase_" & Key
    If CBool(Len(Worksheets(wsName).Name) > 0) = False Then
        Sheets.Add After:=Sheets(Sheets.Count)
        Set ws = ActiveSheet
        ws.Name = wsName
        Sh.Rows("12:13").Copy
    ws.[A12].Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
     
        ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
    Else
        If MsgBox("Sheets " & wsName & " da có. Ban có muôn ghi de không?", vbCritical + vbYesNo, "THÔNG BÁO") = vbYes Then
            ws.[A14].Resize(100000, UBound(Arr, 2)).ClearContents
            ws.[A14].Resize(n, UBound(Arr, 2)) = KQ
        End If
    End If
Next Key
Set Dic = Nothing
MsgBox "Thành công"
End Sub

Em cảm ơn anh giúp đỡ,code chạy kết quả đúng rồi ạ

Maika8008 · Thứ hai lúc 09:21

Ngocminh19 đã viết:
cảm ơn anh đã giúp đỡ
Em thấy các tháng đúng,chỉ có tháng Nov.2025
Dữ liệu em lọc là cột AI : 47734
Nhưng khi tách trong sheet tháng 11 : 43511
Thiếu 1 giá trị ạ. Anh xem giúp em với ạ

Sửa chút đoạn If ... End If cuối cùng

Rich (BB code):

        If i > 1 And i < UBound(arr) - 1 Then
            Set Rng = Ws.Range("A" & arr(1) & ":A" & arr(i) - 1)
            Set Rng = Union(Rng, Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1))
        ElseIf i = UBound(arr) - 1 Then
            Set Rng = Ws.Range("A" & arr(1) & ":A" & arr(i) - 1)
        Else
            Set Rng = Ws.Range("A" & arr(i + 1) & ":A" & arr(UBound(arr)) - 1)
        End If

Maika8008 · Thứ hai lúc 12:31

Góp thêm 1 phương án lấy dữ liệu nữa khi tách sheet: dùng truy vấn SQL

Rich (BB code):

Sub TachSheet_SQL()
Dim Rec As Object, cnn As Object
Dim Ws As Worksheet
Dim i&, d&, SQL$, Adr$, tmpArr
    
    Application.ScreenUpdating = False
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    d = Sheets("Purchase").Range("A" & Rows.Count).End(xlUp).Row
    Adr = Range("A14", Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(13, Columns.Count).End(xlToLeft).Column)).Address(0, 0)
    
    SQL = "Select First(F1) From [Purchase$A14:A" & d & "] Group By F1 "
    Set Rec = cnn.Execute(SQL)
    tmpArr = Rec.GetRows
    d = 0
    For i = 0 To UBound(tmpArr, 2)
        SQL = "Select * From [Purchase$" & Adr & "] Where F1 Like " & "'" & Left(tmpArr(0, i), 3) & "%" & "'"
        Set Rec = cnn.Execute(SQL)
        d = d + 1
        Sheets("Purchase").Copy Before:=Sheets(d + 1)
        Set Ws = Sheets(d + 1)
        Ws.Name = "Purchase" & "_" & Left(tmpArr(0, i), 3) & "." & Right(tmpArr(0, i), 4)
        Ws.Range(Adr).ClearContents
        Ws.Range("A14").CopyFromRecordset Rec
    Next
End Sub

Tách sheet và xóa sheet chỉ định ,giữ nguyên các sheet còn lại (1 người xem)

Người dùng đang xem chủ đề này

Ngocminh19

Thành viên chính thức

File đính kèm

Maika8008

Thành viên gạo cội

DeTong

Thành viên thường trực

Ngocminh19

Thành viên chính thức

Maika8008

Thành viên gạo cội

HUONGHCKT

Zalo 0986997214

Maika8008

Thành viên gạo cội

DeTong

Thành viên thường trực

Maika8008

Thành viên gạo cội

Hoàng Tuấn 868

Đăng ký hôm qua

Maika8008

Thành viên gạo cội

Ngocminh19

Thành viên chính thức

Maika8008

Thành viên gạo cội

Maika8008

Thành viên gạo cội

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

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

Thời gian đếm ngược.