Xin code VBA tách Sheet tổng hợp thành nhiều Sheet chi tiết

[Thanh Binh111]

Xin chào mọi người.
Mình có bài toán này nhờ mọi người giúp đỡ: Mình có sheet dữ liệu tổng hợp ở sheet1, tổng hợp các hạng mục công việc của tất cả các bộ phận. Tên các bộ phận nằm ở vùng A1:N1 của sheet1, đối với mỗi hạng mục công việc nếu bộ phận nào tích "V" thì có nghĩa là có tham gia.
Nhu cầu của mình là: mỗi ngày sau khi cập nhật lại thông tin các cột ở sheet1, bấm nút VBA thì các hạng mục công việc liên quan bộ phận nào sẽ tự động cập nhật vào các sheet Bộ phận tương ứng. Ví dụ như Bộ phận CEO ở sheet1 có tích V 7 mục thì 7 mục đó sẽ tự động cập nhật vào sheet CEO tương ứng.
Xin cảm ơn rất nhiều！

 

[Maika8008]

Tên file đưa lên đây sao không đổi lại theo ký tự Latinh hử bạn?

 

[Thanh Binh111]

Tên file đưa lên đây sao không đổi lại theo ký tự Latinh hử bạn?

Vâng mình xin gửi ạ, nhờ bạn hỗ trợ mình với, cảm ơn bạn!

 

[Hoàng Tuấn 868]

bấm nút VBA

Lần sau mà liên quan đến món "bấm nút VBA" thì bạn đăng vào mục: "Lập trình với Excel" nhé.

 

[Thanh Binh111]

Vâng ạ, cảm ơn bạn nhắc nhở, nhờ bạn và mọi người hỗ trợ mình với ạ.

 

[BuiQuangThuan]

Lần sau mà liên quan đến món "bấm nút VBA" thì bạn đăng vào mục: "Lập trình với Excel" nhé.

Anh có nhã hứng không hỗ trợ người ta với kìa

 

[Hoàng Tuấn 868]

Anh có nhã hứng không hỗ trợ người ta với kìa

Mình đang làm vụ khác mất rồi.

 

[VetMini]

Anh có nhã hứng không hỗ trợ người ta với kìa

Hắn ta đang đợi thiotws thứ ba, đăng vào góc "Lập trình..."

 

[Thanh Binh111]

Hắn ta đang đợi thiotws thứ ba, đăng vào góc "Lập trình..."

Phiền bác hỗ trợ em với ạ, cảm ơn ạ.

 

[Thóc Sama]

Vâng mình xin gửi ạ, nhờ bạn hỗ trợ mình với, cảm ơn bạn!

Bạn thử với con macro này xem được không.
Kiểm tra lại nha, vì mình không biết tiếng "tung của" nên lười ngó.

Option Explicit
Sub GPE()
    Dim cll As Range, lr&, a%, i%
    Dim Ws As Worksheet, Rng As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    With Sheet1
        lr = .Range("Q" & Rows.Count).End(xlUp).Row
        Rows(1).AutoFilter
        For Each cll In .Range("A1:N1")
            Set Rng = Nothing: .ShowAllData:   a = a + 1
            .Range("$A$1:$T$" & lr).AutoFilter Field:=a, Criteria1:="<>"
            For i = 2 To lr
                If Rows(i).EntireRow.Hidden = False Then
                    If Not Rng Is Nothing Then
                        Set Rng = Union(Rng, .Range("O" & i & ":S" & i))
                    Else
                        Set Rng = .Range("O" & i & ":S" & i)
                    End If
                End If
            Next i
            For Each Ws In Sheets
                If Ws.Name = cll.Value Then
                    With Ws
                        .Range("A2:F" & lr).ClearContents
                        Rng.Copy .Range("B2")
                        For i = 2 To lr
                        If .Cells(i, 2) <> "" Then .Cells(i, 1) = "V"
                        Next i
                    End With
                End If
            Next Ws
        Next cll
    End With
    MsgBox "Hoan Thanh"
    Sheet1.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

 

[HUONGHCKT]

Xin chào mọi người.
Mình có bài toán này nhờ mọi người giúp đỡ: Mình có sheet dữ liệu tổng hợp ở sheet1, tổng hợp các hạng mục công việc của tất cả các bộ phận. Tên các bộ phận nằm ở vùng A1:N1 của sheet1, đối với mỗi hạng mục công việc nếu bộ phận nào tích "V" thì có nghĩa là có tham gia.
Nhu cầu của mình là: mỗi ngày sau khi cập nhật lại thông tin các cột ở sheet1, bấm nút VBA thì các hạng mục công việc liên quan bộ phận nào sẽ tự động cập nhật vào các sheet Bộ phận tương ứng. Ví dụ như Bộ phận CEO ở sheet1 có tích V 7 mục thì 7 mục đó sẽ tự động cập nhật vào sheet CEO tương ứng.
Xin cảm ơn rất nhiều！

Trong khi chờ đợi các giải pháp khác hãy thử code này:

Option Explicit

Sub ABC()
Dim i&, j&, Lr&, k&, t&, Col&, Cot&
Dim Arr(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("Data")
Lr = Sh.Cells(1000000, "O").End(xlUp).Row
Col = Sh.Cells(1, 1000).End(xlToLeft).Column
Arr = Sh.Range(Sh.Cells(1, 1), Sh.Cells(Lr, Col)).Value
ReDim KQ(1 To UBound(Arr), 1 To 6)
For j = 1 To 14
    t = 0:
    For i = 2 To UBound(Arr)
        If Arr(i, j) <> Empty Then
            t = t + 1: Cot = 1
            KQ(t, 1) = Arr(i, j)
            For k = 15 To UBound(Arr, 2)
                Cot = Cot + 1
                KQ(t, Cot) = Arr(i, k)
            Next k
        End If
    Next i
    For Each Ws In Worksheets
         If Ws.Name Like Arr(1, j) And Ws.Name <> "Data" Then
            Ws.Range("A2:Y1000").ClearContents
            Ws.Cells(2, 1).Resize(t, 6) = KQ
            Exit For
        End If
    Next Ws
Next j
MsgBox "Xong"
End Sub

P/S tôi đã đổi tên Sheet(tiếng Tàu, Nhật) thành Sheet Data

 

[BuiQuangThuan]

Thao khảo thêm 1 cách khác nữa:

Sub ABC()
    Dim aSheet As Range, Vung As Range, iR&, X, n&
    Application.ScreenUpdating = 0
    With Sheet1
        iR = .Range("O" & Rows.Count).End(3).Row
        Set aSheet = .Range("A1:N" & iR)
        Set Vung = .Range("O1:S" & iR)
        For Each X In .Range("A1:N1")
            n = n + 1
            If WorksheetFunction.CountIf(X.Offset(1).Resize(iR - 1), "v") > 0 Then
                  Sheets(X.Value).Range("B2").Resize(1000, 10).ClearContents
                  aSheet.AutoFilter n, "v"
                  Vung.SpecialCells(12).Copy
                  Sheets(X.Value).Range("B1").PasteSpecial xlPasteValues
                  aSheet.AutoFilter
            End If
        Next
    End With
    Application.ScreenUpdating = 1
End Sub

 

[Maika8008]

Ồ! Anh tài hội tụ đông vui quá. Tui làm rồi mới thấy, chẳng lẽ không góp vui sao
Không đổi tên sheet và cứ có sheet nào thì chạy sheet ấy thôi.

Sub ChiTietCVTungBoPhan()
    Dim i&, j&, k&, c&, iSh&, rw&
    Dim Sh As Worksheet, aData, aRsl

    Set Sh = ThisWorkbook.Sheets(1)
    With Sh
        rw = .Range("O" & Rows.Count).End(xlUp).Row
        aData = .Range("A1:S" & rw).Value
        rw = 1
        For c = 1 To UBound(aData, 2) - 5
            ReDim aRsl(1 To UBound(aData) - 1, 1 To 6)
            For iSh = 2 To ThisWorkbook.Worksheets.Count
                If aData(1, c) = Sheets(iSh).Name Then Exit For
            Next
            For i = 2 To UBound(aData)
                If UCase(aData(i, c)) = "V" Then
                    k = k + 1: aRsl(k, 1) = "V"
                    For j = UBound(aData, 2) - 4 To UBound(aData, 2)
                        rw = rw + 1: aRsl(k, rw) = aData(i, j)
                    Next
                    rw = 1
                End If
            Next
            If iSh <= ThisWorkbook.Worksheets.Count Then
                Sheets(iSh).Range("A2").Resize(k, UBound(aRsl, 2)) = aRsl: k = 0
            End If
        Next
    End With
End Sub

 

[Thanh Binh111]

Mọi người nhiệt tình quá, xin cảm ơn tất cả mọi người đã hỗ trợ ạ!