Tách 1 sheet thành nhiều sheet theo điều kiện

Liên hệ QC
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

  • Tach brand.xlsx
    290.9 KB · Đọc: 58
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

  • Tach brand.xlsm
    615.9 KB · Đọc: 58
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

  • Tách sheet.xlsm
    35.3 KB · Đọc: 34
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

  • test.xlsx
    33.4 KB · Đọc: 14
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

  • test.xlsx
    36 KB · Đọc: 24
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.
 
Cám ơn bác nhiều, em đã làm đượ rồi ạ
 
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

  • Book2.xlsx
    118 KB · Đọc: 7
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

  • Tach brand.xlsb
    213.4 KB · Đọc: 24
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!
 
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

A
TÁCH TIẾNG HÀN VÀ TIẾNG VIỆT RIÊNG
Trả lời
1
Đọc
8
BuiQuangThuan
B
H
Xin giúp đỡ lệnh làm Biên bản giao hàng
Trả lời
0
Đọc
17
hongthuy1992
H
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
5
Đọc
87
yaaasoo01
Y
C
  • Question
VBA copy 2 vùng dữ liệu từ 1 workbook này sang 2 vùng của workbook khác!
    • Phẫn nộ
Trả lời
10
Đọc
126
cuongbv2103
C
H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
14
Đọc
299
hiv174
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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