Nhờ giúp tách sheet từ dữ liệu tổng (1 người xem)

[thuyinfo]

Dữ liệu em có sheet "Nguồn" trong đó có cột "B" là mã các đơn vị
Em muốn dữ liệu nguồn thành nhiều sheet khác nhau dựa vào mã đơn vị ở cột B
Tất cả dữ liệu theo từng đơn vị sẽ chuyển thành nhiều sheet với:
- Tên sheet là mã đơn vị
- Dữ liệu tiêu đề giữ lại ở các sheet
- Toàn bộ các dữ liệu theo mã đơn vị sẽ đi theo sang sheet mới luôn
Chi tiết trong file đính kèm, các bác giúp em với ạ!
Thanks các bác!

 

[vanthinh3101]

Dữ liệu em có sheet "Nguồn" trong đó có cột "B" là mã các đơn vị
Em muốn dữ liệu nguồn thành nhiều sheet khác nhau dựa vào mã đơn vị ở cột B
Tất cả dữ liệu theo từng đơn vị sẽ chuyển thành nhiều sheet với:
- Tên sheet là mã đơn vị
- Dữ liệu tiêu đề giữ lại ở các sheet
- Toàn bộ các dữ liệu theo mã đơn vị sẽ đi theo sang sheet mới luôn
Chi tiết trong file đính kèm, các bác giúp em với ạ!
Thanks các bác!

Bạn tham khảo bài viết này http://www.giaiphapexcel.com/dienda...từng-sheet-theo-điều-kiện.133116/#post-841492

 

[thuyinfo]

Bạn tham khảo bài viết này http://www.giaiphapexcel.com/diendan/threads/tách-dữ-liệu-ra-từng-sheet-theo-điều-kiện.133116/#post-841492

Bạn sửa lại giúp nhé, file bạn viết có 3 cột còn file của mình có 9 cột
=> bạn sửa lại giúp lấy dữ liệu cả 9 cột thì lấy ntn nhé

Sub Tach_sheets()
Dim I As Long, J As Long, K As Long, Ws As Worksheet
Dim Dic As Object, sArr(), tArr, dArr()

sArr() = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown)).Offset(, -1).Resize(, 2).Value

Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(sArr, 1)
If Not Dic.exists(sArr(I, 2)) Then Dic.Add sArr(I, 2), ""
Next I

tArr = Dic.keys
For J = 0 To UBound(tArr)
K = 0
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
Set Ws = Worksheets.Add(, Sheet1)
Ws.Name = tArr(J)
Sheet1.Range("A1:C1").Copy Ws.Range("A1")
For I = 1 To UBound(sArr, 1)
If sArr(I, 2) = tArr(J) Then
K = K + 1
dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
End If
Next I
Ws.Range("A2").Resize(K, 3) = dArr
Erase dArr
Ws.UsedRange.Borders.LineStyle = 1
Ws.Columns("A:C").AutoFit
Next J
MsgBox "Done", vbInformation, "GPE"
End Sub

 

[vanthinh3101]

Bạn sửa lại giúp nhé, file bạn viết có 3 cột còn file của mình có 9 cột
=> bạn sửa lại giúp lấy dữ liệu cả 9 cột thì lấy ntn nhé

Sub Tach_sheets()
Dim I As Long, J As Long, K As Long, Ws As Worksheet
Dim Dic As Object, sArr(), tArr, dArr()

sArr() = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown)).Offset(, -1).Resize(, 2).Value

Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(sArr, 1)
If Not Dic.exists(sArr(I, 2)) Then Dic.Add sArr(I, 2), ""
Next I

tArr = Dic.keys
For J = 0 To UBound(tArr)
K = 0
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
Set Ws = Worksheets.Add(, Sheet1)
Ws.Name = tArr(J)
Sheet1.Range("A1:C1").Copy Ws.Range("A1")
For I = 1 To UBound(sArr, 1)
If sArr(I, 2) = tArr(J) Then
K = K + 1
dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
End If
Next I
Ws.Range("A2").Resize(K, 3) = dArr
Erase dArr
Ws.UsedRange.Borders.LineStyle = 1
Ws.Columns("A:C").AutoFit
Next J
MsgBox "Done", vbInformation, "GPE"
End Sub

Bạn nên đưa file giả định đúng form mẫu để thuận tiện cho mọi người trên diễn đàn xem và đưa giải pháp đúng ngay.
Bạn thử code sau:

Sub Tach_sheets()
    Dim I As Long, J As Long, K As Long, H as Long, Ws As Worksheet
    Dim Dic As Object, sArr(), tArr, dArr()
    
    sArr() = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown)).Offset(,-1).Resize(,9).Value
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 2)) Then Dic.Add sArr(I, 2), ""
    Next I
    
    tArr = Dic.keys
    For J = 0 To UBound(tArr)
        K = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 9)
        Set Ws = Worksheets.Add(, Sheet1)
        Ws.Name = tArr(J)
        Sheet1.Range("A1:I1").Copy Ws.Range("A1")
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 2) = tArr(J) Then
                K = K + 1
                dArr(K, 1) = K
                For H = 2 to 9
                     dArr(K, H) = sArr(I, H)
                Next H
            End If
        Next I
        Ws.Range("A2").Resize(K, 9) = dArr
        Erase dArr
        Ws.UsedRange.Borders.LineStyle = 1
        Ws.Columns("A:I").AutoFit
    Next J
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[thuyinfo]

Bạn nên đưa file giả định đúng form mẫu để thuận tiện cho mọi người trên diễn đàn xem và đưa giải pháp đúng ngay.
Bạn thử code sau:

Sub Tach_sheets()
    Dim I As Long, J As Long, K As Long, H as Long, Ws As Worksheet
    Dim Dic As Object, sArr(), tArr, dArr()
   
    sArr() = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown)).Offset(,-1).Resize(,9).Value
   
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 2)) Then Dic.Add sArr(I, 2), ""
    Next I
   
    tArr = Dic.keys
    For J = 0 To UBound(tArr)
        K = 0
        ReDim dArr(1 To UBound(sArr, 1), 1 To 9)
        Set Ws = Worksheets.Add(, Sheet1)
        Ws.Name = tArr(J)
        Sheet1.Range("A1:I1").Copy Ws.Range("A1")
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 2) = tArr(J) Then
                K = K + 1
                dArr(K, 1) = K
                For H = 2 to 9
                     dArr(K, H) = sArr(I, H)
                Next H
            End If
        Next I
        Ws.Range("A2").Resize(K, 9) = dArr
        Erase dArr
        Ws.UsedRange.Borders.LineStyle = 1
        Ws.Columns("A:I").AutoFit
    Next J
    MsgBox "Done", vbInformation, "GPE"
End Sub

Mình lắp vào file và chạy được rồi nhé, thanks bạn nhiều!

 

[ketoan100]

Nếu mình thay đổi tách sheet nguồn thành 1 workbook mới thì phải thay đổi như thế nào vậy bạn?

 

[vanthinh3101]

Nếu mình thay đổi tách sheet nguồn thành 1 workbook mới thì phải thay đổi như thế nào vậy bạn?

Bạn tham khảo bài viết ở link sau:
http://www.giaiphapexcel.com/dienda...ổng-thành-các-file-nhỏ-theo-điều-kiện.128413/
Để có giải pháp chính xác, bạn nên đưa ra yêu cầu cụ thể với dữ liệu giả định chuẩn.
Chúc bạn cuối tuần vui vẻ.