Tách 1 sheet thành nhiều sheet theo điều kiện (1 người xem)

  • Thread starter Thread starter antit
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

antit

Thành viên mới
Tham gia
1/6/11
Bài viết
1
Được thích
0
Chào Anh/Chị,
Em có 1 file dữ liệu gồm 1 sheet Tổng hợp , Giờ muốn tách sheet tổng hợp này thành nhiều sheet chia theo Brand ạ
Em cảm ơn ạ
 

File đính kèm

antit đã viết:
Chào Anh/Chị,
Em có 1 file dữ liệu gồm 1 sheet Tổng hợp , Giờ muốn tách sheet tổng hợp này thành nhiều sheet chia theo Brand ạ
Em cảm ơn ạ
Nhấp chuột vào đây để mở rộng...
Dùng tạm code này.
Mã: 
Option Explicit

Sub Tach1SheetThanhNhieuSheet()
Dim tTime As Double

Dim Ws As Worksheet
Dim i As Integer
Dim NWs As Worksheet
Dim Odau As Range

'tTime = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

 'XOA
 For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name <> "Sheet1" Then Ws.Delete
Next
Set Ws = ThisWorkbook.Sheets("Sheet1")
    
    Ws.Columns(3).Copy
    Ws.Columns(17).PasteSpecial xlPasteValues
    Ws.Cells(2, 17).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    
    ' Loc cac Đk va tao sheet moi và copy
    i = 2
    While (Ws.Cells(i, 17) <> "")
    Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set NWs = ActiveSheet
    NWs.Name = Ws.Cells(i, 17)
    Ws.Select
    Set Odau = Ws.Range("A1")
    Odau.CurrentRegion.AutoFilter Field:=3, Criteria1:=Ws.Cells(i, 17)
    Odau.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    NWs.Range("A1").PasteSpecial
    NWs.Cells.EntireColumn.AutoFit
    Ws.Select
    Odau.AutoFilter
    i = i + 1
    Wend
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True
    Ws.Columns(17).ClearContents
'Debug.Print Timer - tTime

    MsgBox " Đa hoàn thành"
End Sub
 

File đính kèm

Góp vui thế này:
HTML: 
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 9)
    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:I1")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A2:I" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 3) <> "" Then
                Key = Arr(i, 3)
                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, 3) = Ws.Name Then
                            k = k + 1
                            For j = 1 To 9
                                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, 9).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:I").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
 
THÓC SAMA đã viết:
Góp vui thế này:
HTML: 
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 9)
    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:I1")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A2:I" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 3) <> "" Then
                Key = Arr(i, 3)
                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, 3) = Ws.Name Then
                            k = k + 1
                            For j = 1 To 9
                                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, 9).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:I").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, em có nhờ code của anh mà làm được file của em, nhưng trong file của em cần điền thêm chữ "Bên giao" và "Bên nhận" sau mỗi sheet được tách ra (Tính từ dòng cuối có dữ liệu + 2 dòng trống, thì điền Bên giao và Bên nhận ở cột C và F, vì mỗi PO có số lượng sp khác nhau nên không set cố định vào 1 ô được ạ)
Em gửi file đính kèm, nhờ anh hỗ trợ cho em xin code với ạ.
Em cám ơn nhiều
 

File đính kèm

THÓC SAMA đã viết:
Góp vui thế này:
HTML: 
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 9)
    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:I1")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A2:I" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 3) <> "" Then
                Key = Arr(i, 3)
                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, 3) = Ws.Name Then
                            k = k + 1
                            For j = 1 To 9
                                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, 9).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:I").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy nhanh quá ạ
 
THUYNGUYEN900101 đã viết:
Dạ, em có nhờ code của anh mà làm được file của em, nhưng trong file của em cần điền thêm chữ "Bên giao" và "Bên nhận" sau mỗi sheet được tách ra (Tính từ dòng cuối có dữ liệu + 2 dòng trống, thì điền Bên giao và Bên nhận ở cột C và F, vì mỗi PO có số lượng sp khác nhau nên không set cố định vào 1 ô được ạ)
Em gửi file đính kèm, nhờ anh hỗ trợ cho em xin code với ạ.
Em cám ơn nhiều
Nhấp chuột vào đây để mở rộng...
Gì mà làm việc sớm thế, mình còn đang ăn bánh chưng.
Mách cho bạn nhá, sau khi chạy xong đoạn tách sheets thì thêm phần tìm dòng cuối có dữ liệu, gán chữ “Bên giao” và “ Bên nhận” vào vị trí cột C, F “ở dòng cuối +2” là được rồi.
Bạn biết chỉnh code thì thêm lệnh nhỏ này chắc tự làm được đấy!
 
THÓC SAMA đã viết:
Gì mà làm việc sớm thế, mình còn đang ăn bánh chưng.
Mách cho bạn nhá, sau khi chạy xong đoạn tách sheets thì thêm phần tìm dòng cuối có dữ liệu, gán chữ “Bên giao” và “ Bên nhận” vào vị trí cột C, F “ở dòng cuối +2” là được rồi.
Bạn biết chỉnh code thì thêm lệnh nhỏ này chắc tự làm được đấy!
Nhấp chuột vào đây để mở rộng...
ôi cám ơn anh, em làm được rồi, ngồi mò từng code. Em cám ơn nhiều lắm ạ. Nếu anh có dạy vba, anh cho e xin contact nhé ạ.
 
THUYNGUYEN900101 đã viết:
ôi cám ơn anh, em làm được rồi, ngồi mò từng code. Em cám ơn nhiều lắm ạ. Nếu anh có dạy vba, anh cho e xin contact nhé ạ.
Nhấp chuột vào đây để mở rộng...
Chúc mừng bạn đã tự làm được, bạn muốn học về VBA thì mỗi ngày online vào GPE khoảng 2-3 tiếng nhé, trên này là môi trường tốt để ta học tập đấy, tôi cũng đang đi học thôi, trình độ của tôi hãy còn non và xanh lắm!
 
Nhờ các bác viết giùm em code như file với ạ
Em muốn tách sheet Report (dữ liệu bắt đầu từ AB7 đến cột HF) thành các sheet chia theo Location (cột GT của sheet Report) và vị trí copy dữ liệu qua sheet mới bắt đầu từ cột A7 (kết quả như các sheet BDO, DNO, HCM).
Cám ơn các bác nhiều ạ.
 

File đính kèm

Pivot table bạn nhé sẵn có trong excel mà
 
smallroses93 đã viết:
Nhờ các bác viết giùm em code như file với ạ
Em muốn tách sheet Report (dữ liệu bắt đầu từ AB7 đến cột HF) thành các sheet chia theo Location (cột GT của sheet Report) và vị trí copy dữ liệu qua sheet mới bắt đầu từ cột A7 (kết quả như các sheet BDO, DNO, HCM).
Cám ơn các bác nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Dùng tạm code này:
Mã: 
Option Explicit

Sub Tach1SheetThanhNhieuSheet()
Dim tTime As Double

Dim Ws As Worksheet
Dim i As Integer
Dim NWs As Worksheet
Dim Odau As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

 'XOA
 For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name <> "REPORT" Then Ws.Delete
Next
Set Ws = ThisWorkbook.Sheets("REPORT")
    
    Ws.Range("GT8:GT1000").Copy
    Ws.Cells(1, 217).PasteSpecial xlPasteValues
    Ws.Cells(1, 217).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
    
    ' Loc cac Đk va tao sheet moi và copy
    i = 1
    While (Ws.Cells(i, 217) <> "")
    Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set NWs = ActiveSheet
    NWs.Name = Ws.Cells(i, 217)
    Ws.Select
    Set Odau = Ws.Range("AB7")
    Odau.CurrentRegion.AutoFilter Field:=175, Criteria1:=Ws.Cells(i, 217)
    Odau.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy NWs.Range("A1") '.PasteSpecial
    NWs.Cells.EntireColumn.AutoFit
    Ws.Select
    Odau.AutoFilter
    i = i + 1
    Wend
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Ws.Columns(217).ClearContents
    MsgBox " Đa hoàn thành"
End Sub

Hoặc dùng code của anh @THÓC SAMA ở bài #3 và sửa lại thế này:
Mã: 
Option Explicit

Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 187)
    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 <> "REPORT" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("REPORT")
        Set Rng = .Range("AB7:HF7")
        Lr = .Range("AB" & Rows.Count).End(xlUp).Row
        Arr = .Range("AB8:HF" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 175) <> "" Then
                Key = Arr(i, 175)
                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 <> "REPORT" Then
                    For i = 1 To UBound(Arr)
                        If Arr(i, 175) = Ws.Name Then
                            k = k + 1
                            For j = 1 To UBound(Arr, 2)
                                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, UBound(Arr, 2)).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:GE").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
 
Cám ơn bác em làm được rồi, tuy nhiên khi em tách file thì nó bị mất các những sheet có sẵn mà chỉ ra sheet tổng hợp và sheet cần tách.
Bác có thể chỉnh thêm code giúp em, vẫn giữ nguyên các sheet có sẵn trong file được không ạ
 

File đính kèm

smallroses93 đã viết:
Cám ơn bác em làm được rồi, tuy nhiên khi em tách file thì nó bị mất các những sheet có sẵn mà chỉ ra sheet tổng hợp và sheet cần tách.
Bác có thể chỉnh thêm code giúp em, vẫn giữ nguyên các sheet có sẵn trong file được không ạ
Nhấp chuột vào đây để mở rộng...
Khi tách dữ liệu ra thành cách sheet Thì điều kiện là
chia theo Location (cột GT của sheet Report)
Nhấp chuột vào đây để mở rộng...
mà cột GT ấy chỉ có là BDO, DNO, HCM và lấy luôn các Location ấy làm tên sheet- và tên sheet chỉ là duy nhất, như vậy các sheet cũ sẽ bị xóa đi thay vào đó là các sheet mới tạo. Nếu giữ lại các sheet có sẵn trong workbook thì khi được dữ liệu tách sẽ được ghi vào đâu? Theo code ở bài #11 thì khi chạy code tất cả các sheet có tên khác "REPORT" đều bị xóa. Nếu bạn muốn giữ lại sheet nào thì:
Thay dòng code
Mã: 
If Ws.Name <> "REPORT" Then
Thành
Mã: 
If Ws.Name <> "REPORT" or  Ws.Name <> "tên sheet cần giữ" or Ws.Name <> "tên sheet cần giữ" or ....Then
nếu tên sheet cần giữ mà trùng tên Với Location ở cột GT thì khi Chạy thử, sẽ vấp lỗi Tên sheet không phải là duy nhất.
 
THÓC SAMA đã viết:
Gì mà làm việc sớm thế, mình còn đang ăn bánh chưng.
Mách cho bạn nhá, sau khi chạy xong đoạn tách sheets thì thêm phần tìm dòng cuối có dữ liệu, gán chữ “Bên giao” và “ Bên nhận” vào vị trí cột C, F “ở dòng cuối +2” là được rồi.
Bạn biết chỉnh code thì thêm lệnh nhỏ này chắc tự làm được đấy!
Nhấp chuột vào đây để mở rộng...
bạn có thể giúp mình tách sheet TH này thành nhiều sheet nhỏ theo các tiêu chí ở cột M; mà phần cuối có dòng ngày tháng;ký nhận không ạ? mình không biết gì về viết code cả
 

File đính kèm

HUONGHCKT đã viết:
Có thể chia sẻ cái làm được rồi đó không? để cho nhiều người có thêm kiến thức học hỏi.
Nhấp chuột vào đây để mở rộng...


Mã: 
Option Compare Text
Sub Brand_(Dic As Object, Arr_N(), Arr_Brand())
Dim i As Long, k As Long
Set Dic = CreateObject("Scripting.dictionary")
k = 0
For i = 1 To UBound(Arr_N, 1)
  If Not Dic.exists(Arr_N(i, 9)) Then
    k = k + 1
    Dic.Add Arr_N(i, 9), k
    ReDim Preserve Arr_Brand(1 To k)
     Arr_Brand(k) = Arr_N(i, 9)
  End If
Next

End Sub
Sub Trichloc(Arr_N(), Arr_D(), k As Long, Brand As String)
k = 0
For i = 1 To UBound(Arr_N, 1)
   If Arr_N(i, 9) = Brand Then
    k = k + 1
    For j = 1 To 9
        Arr_D(k, j) = Arr_N(i, j)
    Next
   End If
Next

End Sub
Sub Main()
Dim i As Long, k As Long, Dcuoi As Long, Brand As String
Dim Dic As Object, Sh As Worksheet

Dim Arr_N(), Arr_D(), Arr_Brand()
Dcuoi = Sheet1.Range("A100000").End(xlUp).Row
Arr_N = Sheet1.Range("A2:I" & Dcuoi)
ReDim Arr_D(1 To UBound(Arr_N, 1), 1 To 10)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sh In Worksheets
    If Sh.Name <> "Sheet1" And Sh.Name <> "Sheet2" Then
        Sh.Delete
    End If
Next

Call Brand_(Dic, Arr_N, Arr_Brand)
For i = 1 To UBound(Arr_Brand, 1)
  Brand = Arr_Brand(i)
  Call Trichloc(Arr_N, Arr_D, k, Brand)
   Sheet2.Range("A2:J10000").Clear
   Sheet2.Range("A2").Resize(k, 9).NumberFormat = "@"
   Sheet2.Range("A2").Resize(k, 9) = Arr_D
   Sheet2.Copy after:=Sheet2
   ActiveSheet.Name = Brand
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

bạn muốn học hỏi thì có thể xem code này nếu học được chỗ nào thì học, tôi có đính kèm theo yêu cầu file đầu tiên, lâu lâu viết bài cho đỡ nhớ diễn đàn
 

File đính kèm

trangpth.hti đã viết:
bạn có thể giúp mình tách sheet TH này thành nhiều sheet nhỏ theo các tiêu chí ở cột M; mà phần cuối có dòng ngày tháng;ký nhận không ạ? mình không biết gì về viết code cả
Nhấp chuột vào đây để mở rộng...
Code đã có sẵn đó rồi bạn thử tuỳ chỉnh theo mục đích cá nhân xem sao.
Vướng đâu ta lại hỏi tiếp!
 
Thóc Sama đã viết:
Góp vui thế này:
HTML: 
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 9)
    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:I1")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A2:I" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 3) <> "" Then
                Key = Arr(i, 3)
                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, 3) = Ws.Name Then
                            k = k + 1
                            For j = 1 To 9
                                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, 9).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:I").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...
cái này nếu vừa muốn tách vừa muốn các sheet con tự động thay đổi khi dữ liệu tổng thay đổi thì làm sao ạ
 
ttsuong đã viết:
cái này nếu vừa muốn tách vừa muốn các sheet con tự động thay đổi khi dữ liệu tổng thay đổi thì làm sao ạ
Nhấp chuột vào đây để mở rộng...
Chắc phải thuê người canh, khi nào dữ liệu tổng thay đổi xong hẳn rồi mới bấm nút tách. Chứ không đang thay đổi chưa xong nó đã tách rồi thì bất tiện lắm.
 
Chào Anh/Chị,
Em có 1 file dữ liệu gồm 1 sheet Tổng hợp , Giờ muốn tách sheet tổng hợp này thành nhiều sheet chia theo Mã Cửa Hàng ạ
Em cảm ơn ạ.
 

File đính kèm

File đính kèm

File đính kèm

Minh Nhựt7121 đã viết:
bạn ơi, file hôm qua mình quên chừa dự phòng tăng số cột nhiều hơn hiện tại, bạn có thể chỉnh lại giùm mình với file mới này không ạ. cám ơn bạn.
Nhấp chuột vào đây để mở rộng...
Mượn code của Anh @CHAOQUAY để làm bài.
Mong 2 anh @Hoàng Tuấn 868 và Anh @CHAOQUAY thông cảm về sự "lanh chanh" này.
Mã: 
Option Explicit
'By ChaoQuay
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, C&, Arr()
    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 <> "TH" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("TH")
        C = .Range("B4").End(xlToRight).Column
        Set Rng = .Range(.Cells(1, 2), .Cells(5, C))
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = Range(.Cells(6, 2), .Cells(Lr, C)).Value

        For i = 1 To UBound(Arr)
            If Arr(i, 2) <> "" Then
                Key = Arr(i, 2)
                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 <> "TH" Then
                    ReDim Res(1 To UBound(Arr), 1 To C)
                    For i = 1 To UBound(Arr)
                        If Arr(i, 2) = Ws.Name Then
                            k = k + 1: Res(k, 1) = k
                            For j = 2 To 10
                                Res(k, j) = Arr(i, j)
                            Next j
                        End If
                    Next i
                End If
                If k Then
                    Rng.Copy Ws.Range("B1")
                    Ws.Range("B6").Resize(k, C).Value = Res
                    Ws.Range("D6").CurrentRegion.Borders.LineStyle = 1
                    Ws.Range("D6").CurrentRegion.EntireColumn.AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
 
HUONGHCKT đã viết:
Mượn code của Anh @CHAOQUAY để làm bài.
Mong 2 anh @Hoàng Tuấn 868 và Anh @CHAOQUAY thông cảm về sự "lanh chanh" này.
Mã: 
Option Explicit
'By ChaoQuay
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, C&, Arr()
    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 <> "TH" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("TH")
        C = .Range("B4").End(xlToRight).Column
        Set Rng = .Range(.Cells(1, 2), .Cells(5, C))
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = Range(.Cells(6, 2), .Cells(Lr, C)).Value

        For i = 1 To UBound(Arr)
            If Arr(i, 2) <> "" Then
                Key = Arr(i, 2)
                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 <> "TH" Then
                    ReDim Res(1 To UBound(Arr), 1 To C)
                    For i = 1 To UBound(Arr)
                        If Arr(i, 2) = Ws.Name Then
                            k = k + 1: Res(k, 1) = k
                            For j = 2 To 10
                                Res(k, j) = Arr(i, j)
                            Next j
                        End If
                    Next i
                End If
                If k Then
                    Rng.Copy Ws.Range("B1")
                    Ws.Range("B6").Resize(k, C).Value = Res
                    Ws.Range("D6").CurrentRegion.Borders.LineStyle = 1
                    Ws.Range("D6").CurrentRegion.EntireColumn.AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...
Dữ liệu chạy thử không ra hết rồi bạn ơi, còn định dạng font chữ, số vs kích thước cột không giống sheet ban đầu. thấy code của bạn Hoàng Tuấn 868 khá ổn á.
 
Minh Nhựt7121 đã viết:
Dữ liệu chạy thử không ra hết rồi bạn ơi, còn định dạng font chữ, số vs kích thước cột không giống sheet ban đầu. thấy code của bạn Hoàng Tuấn 868 khá ổn á.
Nhấp chuột vào đây để mở rộng...
Lẽ ra bạn cảm ơn người đã hỗ trợ bạn trước thì vui hơn. Còn muốn giữ nguyên định dạng các thứ thì tham khảo thêm code này:
Mã: 
Sub ABC()
    Dim Dic As Object, Ws As Worksheet, iR&, sArr(), i&, Key, S, Rng As Range
    Set Ws = Sheets("TH")
    Set Dic = CreateObject("scripting.dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With Ws
        iR = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C6:C" & iR).value
        For i = 1 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "|" & i + 5
        Next
    End With
    For Each Key In Dic.keys
        S = Split(Dic(Key), "|")
        Ws.Copy after:=Ws
        ActiveSheet.Name = Key
        With Sheets(Key)
            For i = 6 To iR
                If Not IsInArray(CStr(i), S) Then
                    If Rng Is Nothing Then
                        Set Rng = .Rows(i)
                    Else
                        Set Rng = Union(Rng, .Rows(i))
                    End If
                End If
            Next
            Rng.Delete
            .Cells(6, 2).value = 1
            Set Rng = Nothing
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Function IsInArray(value As Variant, arr As Variant) As Boolean
    Dim i&
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next
End Function
 
Lần chỉnh sửa cuối:
BuiQuangThuan đã viết:
...
Function IsInArray(value As Variant, arr As Variant) As Boolean
Dim i&
IsInArray = False
For i = LBound(arr) To UBound(arr)
If arr(i) = value Then
IsInArray = True
Exit Function
End If
Next
End Function
Nhấp chuột vào đây để mở rộng...

Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
 
VetMini đã viết:
Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
Nhấp chuột vào đây để mở rộng...
Cám ơn chú đã góp ý. Sau khi code xong. Cháu cũng nhận ra có thể thay instr. Mà sợ nó dính trùng ví dụ như 1 và 11 hoặc 12. Cháu xin cám ơn chú vì đã chỉ thêm cho cháu thêm thuật toán khác. Cám ơn chú nhiều ạ
Bài đã được tự động gộp:

VetMini đã viết:
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then
Nhấp chuột vào đây để mở rộng...
Đoạn này của chú đã giải quyết được vấn đề mà cháu đang lăn tăn.
 
Minh Nhựt7121 đã viết:
bạn viết pro quá, cám ơn nhiều nhé.
thank bác nhiều.
Nhấp chuột vào đây để mở rộng...
Minh Nhựt7121 đã viết:
bạn ơi, file hôm qua mình quên chừa dự phòng tăng số cột nhiều hơn hiện tại, bạn có thể chỉnh lại giùm mình với file mới này không ạ. cám ơn bạn.
Nhấp chuột vào đây để mở rộng...
Điều chỉnh thì thêm một chút thôi, nhưng do sử dụng tiếng Tây bồi nên bài này không hỗ trợ nữa. Thông cảm nhé.
 
VetMini đã viết:
Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
Nhấp chuột vào đây để mở rộng...
Chú cho xin đoạn code mới được không ạ.
Bài đã được tự động gộp:

BuiQuangThuan đã viết:
Lẽ ra bạn cảm ơn người đã hỗ trợ bạn trước thì vui hơn. Còn muốn giữ nguyên định dạng các thứ thì tham khảo thêm code này:
Mã: 
Sub ABC()
    Dim Dic As Object, Ws As Worksheet, iR&, sArr(), i&, Key, S, Rng As Range
    Set Ws = Sheets("TH")
    Set Dic = CreateObject("scripting.dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With Ws
        iR = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C6:C" & iR).value
        For i = 1 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "|" & i + 5
        Next
    End With
    For Each Key In Dic.keys
        S = Split(Dic(Key), "|")
        Ws.Copy after:=Ws
        ActiveSheet.Name = Key
        With Sheets(Key)
            For i = 6 To iR
                If Not IsInArray(CStr(i), S) Then
                    If Rng Is Nothing Then
                        Set Rng = .Rows(i)
                    Else
                        Set Rng = Union(Rng, .Rows(i))
                    End If
                End If
            Next
            Rng.Delete
            .Cells(6, 2).value = 1
            Set Rng = Nothing
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Function IsInArray(value As Variant, arr As Variant) As Boolean
    Dim i&
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next
End Function
Nhấp chuột vào đây để mở rộng...
cám ơn ạ.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

huytamlinh
Anh Chị giúp em sửa lỗi định dạng với ạ ! (4 người xem)
Trả lời
2
Đọc
21
huytamlinh
huytamlinh
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail. (3 người xem)
    • Thích
    • Yêu thích
Trả lời
18
Đọc
3K
Võ Việt Tuyến
V
S
Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). Thank (1 người xem)
Trả lời
0
Đọc
8
samthai8017
S
S
Xin hỏi các pro. Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). (3 người xem)
Trả lời
2
Đọc
36
samthai8017
S
T
  • Question Question
Code VBA tra cứu kết quả trả về mảng dữ liệu (2 người xem)
    • Cười
Trả lời
10
Đọc
231
HUONGHCKT
H
T
  • Question Question
Xin giúp em mã lệnh tổng hợp tự động lên bảng tổng hợp! (1 người xem)
Trả lời
1
Đọc
39
Hoàng Tuấn 868
H
T
Nhờ anh chị tìm giúp nguyên nhân không nhảy dữ liệu Pivotable (1 người xem)
Trả lời
0
Đọc
32
thuhacoicoi
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính (1 người xem)
    • Thích
Trả lời
4
Đọc
894
nguyendang95
N
Gà Công Nghệ
Nhờ anh chị chuyển hộ font chữ excel (2 người xem)
Trả lời
2
Đọc
69
Gà Công Nghệ
Gà Công Nghệ
V
Quản lý xuất nhập vật tư trong kho (1 người xem)
Trả lời
19
Đọc
751
LOGANWover
L
phuongnam366377
Học C++ từ số 0 – Bài học đầu tiên
    • Cảm ơn
Trả lời
4
Đọc
339
phuongnam366377
phuongnam366377
F
Mấy cao thủ giúp dùm mình với. File excel bị lỗi mà mình không biết lỗi chỗ nào để sửa.
Trả lời
2
Đọc
99
firstbood
F
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
438
Đọc
58K
sát thủ uyên ương
S
X
Làm thế nào để ẩn "Blank" trong Pivot table
    • Thích
Trả lời
15
Đọc
36K
nguyenngochieu761321
nguyenngochieu761321
H
Đánh số thự theo lượt
Trả lời
5
Đọc
150
hongminh_0306
H
D
XIN PHẦN MỀM XẾP TKB TIỂU HỌC BẰNG EXCEL
Trả lời
2
Đọc
197
danhpheo
D
A
  • Question Question
Copy 2 form sang file khác, có 1 form Show, 1 form không Show
Trả lời
2
Đọc
150
AnhThu-1976
A
R
Các bác có kinh nghiệm excel cho em xin công thức đánh số thứ tự theo ngày tháng này vợi ạ.
Trả lời
5
Đọc
219
truc.duong87
T
H
Tự động cập nhật dữ liệu từ 2 file word
Trả lời
1
Đọc
161
LOGANWover
L
N
Nhờ giúp Drop down list theo tỉnh xã mới. (1 người xem)
Trả lời
7
Đọc
349
ongke0711
ongke0711
Xem thêm…

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.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom