Lọc và gom dữ liệu theo nhóm bằng VBA

[thao nguyen01]

Kính gửi anh/ chị trên diễn đàn,

Em bị vướng vấn đề sau ạ: Em muốn lấy từ data và cho kết quả trong file em mô tả ạ. Em viết code bên sheet báo cáo, nhưng em chỉ mới lấy dữ liệu ra ạ. Anh/chị xem giúp em ạ. Bài này em nghĩ dùng Pivot sẽ ra, nhưng vì em muốn học cách viết code ạ. Anh/chị xem giúp em ạ. Em cảm ơn nhiều ạ

Code em viết ạ nhưng khi gom theo nhóm em chưa nghĩ ra ạ:

Sub baocao()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim ngay As Date
Dim arr_N()
Dim arr_D()

dcuoi = Sheet1.Range("a100000").End(xlUp).Row
arr_N = Sheet1.Range("a3" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 9)
k = 0
ngay = Sheet2.Range("C1")

For i = 1 To UBound(arr_N, 1)
If arr_N(i, 1) = ngay Then
k = k + 1
arr_D(k, 1) = k
arr_D(k, 2) = arr_N(i, 1)
arr_D(k, 3) = arr_N(i, 2)
arr_D(k, 4) = arr_N(i, 3)
End If
Next
If k = 0 Then
MsgBox " khong co data thoa dk"
Exit Sub
End If

Sheet2.Range("a4:E10000").Clear
Sheet2.Range("a4").Resize(k, 5) = arr_D
End Sub

 

[snow25]

Kính gửi anh/ chị trên diễn đàn,

Em bị vướng vấn đề sau ạ: Em muốn lấy từ data và cho kết quả trong file em mô tả ạ. Em viết code bên sheet báo cáo, nhưng em chỉ mới lấy dữ liệu ra ạ. Anh/chị xem giúp em ạ. Bài này em nghĩ dùng Pivot sẽ ra, nhưng vì em muốn học cách viết code ạ. Anh/chị xem giúp em ạ. Em cảm ơn nhiều ạ

Code em viết ạ nhưng khi gom theo nhóm em chưa nghĩ ra ạ:

Sub baocao()
Dim i As Long
Dim k As Long
Dim dcuoi As Long
Dim ngay As Date
Dim arr_N()
Dim arr_D()

dcuoi = Sheet1.Range("a100000").End(xlUp).Row
arr_N = Sheet1.Range("a3" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 9)
k = 0
ngay = Sheet2.Range("C1")

For i = 1 To UBound(arr_N, 1)
If arr_N(i, 1) = ngay Then
k = k + 1
arr_D(k, 1) = k
arr_D(k, 2) = arr_N(i, 1)
arr_D(k, 3) = arr_N(i, 2)
arr_D(k, 4) = arr_N(i, 3)
End If
Next
If k = 0 Then
MsgBox " khong co data thoa dk"
Exit Sub
End If

Sheet2.Range("a4:E10000").Clear
Sheet2.Range("a4").Resize(k, 5) = arr_D
End Sub

Bạn thử code này nhé.

Sub laydulieu()
   Dim arr, i As Long, dic As Object, lr As Long, a As Long, kq, dk As String, T, ngay As Long, b As Long, data, T1
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A3:D" & lr).Value
        ReDim kq(1 To UBound(arr) + 10, 1 To 5)
   End With
   With Sheet2
        ngay = .Range("C1").Value2
       For i = 1 To UBound(arr)
           If ngay = CLng(arr(i, 1)) Then
              dk = arr(i, 2)
              If Not dic.exists(dk) Then
                 dic.Add dk, Array(i, arr(i, 4))
              Else
                 dic.Item(dk) = Array(dic.Item(dk)(0) & "#" & i, dic.Item(dk)(1) + arr(i, 4))
              End If
          End If
       Next i
     For Each T1 In dic.keys
         a = a + 1
         b = 0
         dk = T1
         kq(a, 3) = dk
         kq(a, 5) = dic.Item(dk)(1)
         For Each T In Split(dic.Item(dk)(0), "#")
             a = a + 1
             b = b + 1
             kq(a, 1) = b
             kq(a, 2) = arr(T, 1)
             kq(a, 3) = arr(T, 2)
             kq(a, 4) = arr(T, 3)
             kq(a, 5) = arr(T, 4)
        Next
    Next
    lr = .Range("C" & Rows.Count).End(xlUp).Row
    If lr > 3 Then .Range("A4:E" & lr).ClearContents
    If a Then .Range("A4:E4").Resize(a).Value = kq
 End With
End Sub

 

[thao nguyen01]

Bạn thử code này nhé.

Sub laydulieu()
   Dim arr, i As Long, dic As Object, lr As Long, a As Long, kq, dk As String, T, ngay As Long, b As Long, data, T1
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A3:D" & lr).Value
        ReDim kq(1 To UBound(arr) + 10, 1 To 5)
   End With
   With Sheet2
        ngay = .Range("C1").Value2
       For i = 1 To UBound(arr)
           If ngay = CLng(arr(i, 1)) Then
              dk = arr(i, 2)
              If Not dic.exists(dk) Then
                 dic.Add dk, Array(i, arr(i, 4))
              Else
                 dic.Item(dk) = Array(dic.Item(dk)(0) & "#" & i, dic.Item(dk)(1) + arr(i, 4))
              End If
          End If
       Next i
     For Each T1 In dic.keys
         a = a + 1
         b = 0
         dk = T1
         kq(a, 3) = dk
         kq(a, 5) = dic.Item(dk)(1)
         For Each T In Split(dic.Item(dk)(0), "#")
             a = a + 1
             b = b + 1
             kq(a, 1) = b
             kq(a, 2) = arr(T, 1)
             kq(a, 3) = arr(T, 2)
             kq(a, 4) = arr(T, 3)
             kq(a, 5) = arr(T, 4)
        Next
    Next
    lr = .Range("C" & Rows.Count).End(xlUp).Row
    If lr > 3 Then .Range("A4:E" & lr).ClearContents
    If a Then .Range("A4:E4").Resize(a).Value = kq
End With
End Sub

Dạ, em cảm ơn anh nhiều ạ.