Nhờ giúp code VBA báo cáo

[babyheomoi]

Xin chào mọi người, em có vấn đề nhỏ cần mọi người hỗ trợ ạ!
Em có 1 cái file data, và cần lọc ra file báo cáo!
Chuyện là xài hàm cũng ổn, nhưng data lớn quá nên hay bi lag và treo máy (tầm 3000 dòng và 100 cột) - chắc máy em già rồi!
Mọi người giúp em code cho nhanh gọn được không ạ? Cơ bản data có các lưu ý như sau:
1. 1 Khách hàng có thể có nhiều hơn 1 công trình
2. Trong các công trình của 1 khách hàng có thể có hơn 1 một người quản lý
Em cám ơn trước ạ!

 

[babyheomoi]

Đúng rồi, Do cách thử của bạn , hoặc có thể tôi viết code không đúng ý định của bạn
1/Code 1 là tổng hợp toàn bộ những Điều kiện ở 2 ô B8,B9 cứ đúng ĐK là trả về kết quả. Như hình là bạn chỉ có chọn 1 QL C do vậy nó sẽ lấy tất cả QL C ở trong CSDL,
2/Còn code 2 là nó sẽ tổng hợp theo ĐK ở 2 ô trên. nếu chỉ có 1 QL C thì nó sẽ cộng Tất cả các dòng có C theo từng cột tương ứng với DS A, DS B.... Tongcong.Nếu là 2 QL (Vd: A, C) và 3 khách hàng (ví dụ PI PI, Vin Grup, HUNG NHAN,...) thì nó sẽ lọc ra A có mấy PI PI và công lại theo các cột DS A, Ds B ... tương ứng, lọc tiếp đến C cũng như vậy cho đến hết QL thì thôi.

Bây giờ bạn thử lại thế này: Ô B8 bạn nhập 1 hoặc 2 hoặc 3 QL (Vdu: A, B, C)
Ô B9 bạn nhập 1,2,3 4, 5 khách hàng và chạy thử code 2 xem kết quả.

dạ vâng, em làm như anh nói thì đúng thế, nhưng cái kết quả em mong muốn là như trong hình đó a! Tức là ô b9 để rỗng thì vẫn lọc hết ra, nhưng sum mấy KH trùng nhau lại
Trên ảnh đầu là code 1, ảnh sau là code 2 mong muốn!
Em cám ơn

 

[HUONGHCKT]

dạ vâng, em làm như anh nói thì đúng thế, nhưng cái kết quả em mong muốn là như trong hình đó a! Tức là ô b9 để rỗng thì vẫn lọc hết ra, nhưng sum mấy KH trùng nhau lại
Trên ảnh đầu là code 1, ảnh sau là code 2 mong muốn!
Em cám ơn

Không hiểu ý nên không gặp nhau tại một điểm.
Sửa lại code: Đưa vòng lặp For i lên đầu, và thêm ĐK khách hàng là từng dòng của Dữ liệu vào nếu tìm thấy QL.
Trường hợp B8 rỗng, B9 không rỗng thì bạn tính thế nào? cũng Sum lại những quản lý trùng nhau hay không? Trong code dưới đây mình đã làm là sum lại.

Thay code sau vào

Sub TONGHOP()
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
Dim i&, j&, t&, Lr&, K&
Dim Arr(), KQ(), QL, KH
Dim DK, DK1
On Error Resume Next
With Sheets("DATA")
Lr = .Range("B" & Rows.Count).End(xlUp).Row
Arr = .Range("B2:J" & Lr).Value
End With
ReDim KQ(1 To UBound(Arr), 1 To 8)
QLname = Sheets("REPORT").Cells(8, 2)
KHname = Sheets("REPORT").Cells(9, 2)
QL = Split(QLname, ","): KH = Split(KHname, ",")
Q = UBound(QL): K = UBound(KH):
If Q = -1 Then Q = 0
If K = -1 Then K = 0
For i = 1 To UBound(Arr)
    For h = 0 To Q
        For m = 0 To K
            If Q = 0 Then
                If KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
            Else
                If KHname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
           
            If K = 0 Then
                If QLname <> Empty Then DK = Trim(KHname) & Trim(Arr(i, 2))
            Else
                If QLname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
           
            If Q = 0 And K = 0 Then DK = Trim(QL(h)) & Trim(KH(m))
            If KHname = Empty And QLname <> Empty Then DK = Trim(QL(h)) & Trim(Arr(i, 2))
            If QLname = Empty And KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
       
          DK1 = Trim(Arr(i, 3)) & Trim(Arr(i, 2))
         
                If DK1 = DK Then
                    If Not dic.Exists(DK) Then
                        t = t + 1
                        dic.Add DK, t
                            KQ(t, 1) = t: KQ(t, 2) = Arr(i, 3): KQ(t, 3) = Arr(i, 2)
                        For n = 5 To 9
                            KQ(t, n - 1) = Arr(i, n)
                        Next n
                    Else
                        j = dic.Item(DK)
                        For n = 5 To 9
                            KQ(j, n - 1) = KQ(j, n - 1) + Arr(i, n)
                        Next n
                    End If
                End If
           ' Next i
        Next m
Next h
Next i

If t Then
Sheet2.[J11].Resize(t + 10, 9).ClearContents
Sheet2.[J11].Resize(t, 8) = KQ
End If
Set dic = Nothing
MsgBox "XONG"
End Sub
[Code]

 

[babyheomoi]

Không hiểu ý nên không gặp nhau tại một điểm.
Sửa lại code: Đưa vòng lặp For i lên đầu, và thêm ĐK khách hàng là từng dòng của Dữ liệu vào nếu tìm thấy QL.
Trường hợp B8 rỗng, B9 không rỗng thì bạn tính thế nào? cũng Sum lại những quản lý trùng nhau hay không? Trong code dưới đây mình đã làm là sum lại.

Thay code sau vào

Sub TONGHOP()
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
Dim i&, j&, t&, Lr&, K&
Dim Arr(), KQ(), QL, KH
Dim DK, DK1
On Error Resume Next
With Sheets("DATA")
Lr = .Range("B" & Rows.Count).End(xlUp).Row
Arr = .Range("B2:J" & Lr).Value
End With
ReDim KQ(1 To UBound(Arr), 1 To 8)
QLname = Sheets("REPORT").Cells(8, 2)
KHname = Sheets("REPORT").Cells(9, 2)
QL = Split(QLname, ","): KH = Split(KHname, ",")
Q = UBound(QL): K = UBound(KH):
If Q = -1 Then Q = 0
If K = -1 Then K = 0
For i = 1 To UBound(Arr)
    For h = 0 To Q
        For m = 0 To K
            If Q = 0 Then
                If KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
            Else
                If KHname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
          
            If K = 0 Then
                If QLname <> Empty Then DK = Trim(KHname) & Trim(Arr(i, 2))
            Else
                If QLname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
          
            If Q = 0 And K = 0 Then DK = Trim(QL(h)) & Trim(KH(m))
            If KHname = Empty And QLname <> Empty Then DK = Trim(QL(h)) & Trim(Arr(i, 2))
            If QLname = Empty And KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
      
          DK1 = Trim(Arr(i, 3)) & Trim(Arr(i, 2))
        
                If DK1 = DK Then
                    If Not dic.Exists(DK) Then
                        t = t + 1
                        dic.Add DK, t
                            KQ(t, 1) = t: KQ(t, 2) = Arr(i, 3): KQ(t, 3) = Arr(i, 2)
                        For n = 5 To 9
                            KQ(t, n - 1) = Arr(i, n)
                        Next n
                    Else
                        j = dic.Item(DK)
                        For n = 5 To 9
                            KQ(j, n - 1) = KQ(j, n - 1) + Arr(i, n)
                        Next n
                    End If
                End If
           ' Next i
        Next m
Next h
Next i

If t Then
Sheet2.[J11].Resize(t + 10, 9).ClearContents
Sheet2.[J11].Resize(t, 8) = KQ
End If
Set dic = Nothing
MsgBox "XONG"
End Sub
[Code]

Dạ, quản lý thì ko sum, chỉ sum khách hàng thôi a, e đang thử lại code a! em cám ơn

 

[babyheomoi]

Không hiểu ý nên không gặp nhau tại một điểm.
Sửa lại code: Đưa vòng lặp For i lên đầu, và thêm ĐK khách hàng là từng dòng của Dữ liệu vào nếu tìm thấy QL.
Trường hợp B8 rỗng, B9 không rỗng thì bạn tính thế nào? cũng Sum lại những quản lý trùng nhau hay không? Trong code dưới đây mình đã làm là sum lại.

Thay code sau vào

Sub TONGHOP()
Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
Dim i&, j&, t&, Lr&, K&
Dim Arr(), KQ(), QL, KH
Dim DK, DK1
On Error Resume Next
With Sheets("DATA")
Lr = .Range("B" & Rows.Count).End(xlUp).Row
Arr = .Range("B2:J" & Lr).Value
End With
ReDim KQ(1 To UBound(Arr), 1 To 8)
QLname = Sheets("REPORT").Cells(8, 2)
KHname = Sheets("REPORT").Cells(9, 2)
QL = Split(QLname, ","): KH = Split(KHname, ",")
Q = UBound(QL): K = UBound(KH):
If Q = -1 Then Q = 0
If K = -1 Then K = 0
For i = 1 To UBound(Arr)
    For h = 0 To Q
        For m = 0 To K
            If Q = 0 Then
                If KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
            Else
                If KHname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
          
            If K = 0 Then
                If QLname <> Empty Then DK = Trim(KHname) & Trim(Arr(i, 2))
            Else
                If QLname <> Empty Then DK = Trim(QL(h)) & Trim(KH(m))
            End If
          
            If Q = 0 And K = 0 Then DK = Trim(QL(h)) & Trim(KH(m))
            If KHname = Empty And QLname <> Empty Then DK = Trim(QL(h)) & Trim(Arr(i, 2))
            If QLname = Empty And KHname <> Empty Then DK = Trim(Arr(i, 3)) & Trim(KH(m))
      
          DK1 = Trim(Arr(i, 3)) & Trim(Arr(i, 2))
        
                If DK1 = DK Then
                    If Not dic.Exists(DK) Then
                        t = t + 1
                        dic.Add DK, t
                            KQ(t, 1) = t: KQ(t, 2) = Arr(i, 3): KQ(t, 3) = Arr(i, 2)
                        For n = 5 To 9
                            KQ(t, n - 1) = Arr(i, n)
                        Next n
                    Else
                        j = dic.Item(DK)
                        For n = 5 To 9
                            KQ(j, n - 1) = KQ(j, n - 1) + Arr(i, n)
                        Next n
                    End If
                End If
           ' Next i
        Next m
Next h
Next i

If t Then
Sheet2.[J11].Resize(t + 10, 9).ClearContents
Sheet2.[J11].Resize(t, 8) = KQ
End If
Set dic = Nothing
MsgBox "XONG"
End Sub
[Code]

Code này chạy rất ok anh nhé, cám ơn anh!
Sẵn em đang làm cách 2 Pivot Table, nhưng gặp 1 số vấn đề sau, mong các anh giúp đỡ luôn ạ!
1. Trình bày trong Pivot như 1 báo cáo thông thường sếp yêu cầu quả thật hơi khó với em, mò mãi cũng chưa tới đâu, vậy không biết có tài liệu hay topic nào hướng dẫn về cái này không ạ?
2. Nhờ mọi người giúp em vướng mắc về trình bày theo file theo up lên ạ?
3. Không biết có cách nào dạng như copy pivot hay dựa vào pivot rồi tham chiếu qua form mình yêu cầu không, để khi data đổi => pivot đổi => báo cáo đổi theo ạ!
4. Em sử dụng chức năng chụp ảnh excel để khỏi phải insert thêm 1 pivot (vì dữ liệu tương tự), có điều cần 1 báo cáo chi tiết và 1 báo cáo rút gọn. Tuy nhiên khi em expain pivot ra thì hình ảnh ban đầu cũng đổi theo, vậy có cách nào cố định hình không ạ? (Như file đính kèm)
Em cám ơn!

 

[HUONGHCKT]

Code này chạy rất ok anh nhé, cám ơn anh!
Sẵn em đang làm cách 2 Pivot Table, nhưng gặp 1 số vấn đề sau, mong các anh giúp đỡ luôn ạ!
1. Trình bày trong Pivot như 1 báo cáo thông thường sếp yêu cầu quả thật hơi khó với em, mò mãi cũng chưa tới đâu, vậy không biết có tài liệu hay topic nào hướng dẫn về cái này không ạ?
2. Nhờ mọi người giúp em vướng mắc về trình bày theo file theo up lên ạ?
3. Không biết có cách nào dạng như copy pivot hay dựa vào pivot rồi tham chiếu qua form mình yêu cầu không, để khi data đổi => pivot đổi => báo cáo đổi theo ạ!
4. Em sử dụng chức năng chụp ảnh excel để khỏi phải insert thêm 1 pivot (vì dữ liệu tương tự), có điều cần 1 báo cáo chi tiết và 1 báo cáo rút gọn. Tuy nhiên khi em expain pivot ra thì hình ảnh ban đầu cũng đổi theo, vậy có cách nào cố định hình không ạ? (Như file đính kèm)
Em cám ơn!

Nói thật là mình không có nhiều kiến thức về Pivot Table nên không giúp được bạn.
Bạn cứ đăng vấn đề cần giúp lên diễn đàn là sẽ có người ra tay thội. Theo dõi trên diễn đàn mình thấy có Anh PTM, anh Batman, anh Befain, anh HieuCD, anh Maika, hoangtuan, binbo, be-09,.... và một số anh, chị em nữa mình không nhớ hết, rất rất giỏi về VBA nói riêng và Pivot Table nói chung.

 

[babyheomoi]

Dạ, e đưa lên để mọi người xem giúp ạ!

 

[be_09]

Dạ, e đưa lên để mọi người xem giúp ạ!

Có vài thành viên hay xỉa xói, móc ngéo nên lúc này tôi ít vào xem và viết bài lắm. Nhưng đã 15 ngày mà không thấy ai giúp để hoàn thiện, đưa cái File với cái PivotTable mong muốn lên đi tôi nghiên cứu làm giúp cho.

 

[babyheomoi]

Có vài thành viên hay xỉa xói, móc ngéo nên lúc này tôi ít vào xem và viết bài lắm. Nhưng đã 15 ngày mà không thấy ai giúp để hoàn thiện, đưa cái File với cái PivotTable mong muốn lên đi tôi nghiên cứu làm giúp cho.

dạ, em cám ơn anh!
Em up file lên để mọi người giúp em ạ! Em có ghi chú ổ sheet Nhu cầu ạ!
Em cám ơn!