Xin giúp! Lọc dữ liệu theo quy luật (chỉ dùng VBA)

[miphp]

có vấn đề mà nghĩ mãi chưa ra, nên đành nhờ các Bác giúp.
trong file đính kèm, bảng 1 là dữ liệu gốc, để phục vụ việc in ấn lên những mẫu phiếu hiện hành, nên buộc phải tạo dữ liệu có cấu trúc như bảng 2. (chỉ dùng VBA)

Bác nào rảnh xem qua hộ emvới ạ.
Cảm ơn các bác trước

 

[sealand]

Code cho bạn (Vùng tuỳ biến bạn thay được phải không)

Sub Thop()
Dim Tm, Kq(), i, j, k
Dim Cl As New Collection
Tm = Sheet1.[B7:D12]
On Error Resume Next
For i = 1 To UBound(Tm, 1)
Cl.Add Tm(i, 3), Tm(i, 3)
If Err.Number <> 0 Then
Err.Clear
Else
k = k + 1
ReDim Preserve Kq(1 To 4, 1 To k)
Kq(1, k) = k
Kq(3, k) = Tm(i, 3)
Kq(4, k) = WorksheetFunction.CountIf(Sheet1.[D7:D12], Tm(i, 3))
For j = 1 To UBound(Tm, 1)
If Tm(j, 3) = Tm(i, 3) Then
k = k + 1
ReDim Preserve Kq(1 To 4, 1 To k)
Kq(1, k) = k
Kq(2, k) = Tm(j, 2)
End If
Next
End If
Next
Sheet1.[F7:I1000].ClearContents
Sheet1.[F7].Resize(k, 4) = WorksheetFunction.Transpose(Kq)
End Sub

 

[miphp]

Cảm ơn bácsealand nhé e làm được rồi,http://www.giaiphapexcel.com/forum/member.php?55937-sealand

 

[hpkhuong]

có vấn đề mà nghĩ mãi chưa ra, nên đành nhờ các Bác giúp.
trong file đính kèm, bảng 1 là dữ liệu gốc, để phục vụ việc in ấn lên những mẫu phiếu hiện hành, nên buộc phải tạo dữ liệu có cấu trúc như bảng 2. (chỉ dùng VBA)

Bác nào rảnh xem qua hộ emvới ạ.
Cảm ơn các bác trước

Public Sub GPE()
Dim Dic As Object, Tmp As String, I As Long, K As Long, sArr, dArr, N As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("B7:D12").Value
ReDim dArr(1 To UBound(sArr) * UBound(sArr, 2), 1 To 4)
For I = 1 To UBound(sArr)
    Tmp = sArr(I, 3)
    If Not Dic.exists(Tmp) Then
        K = K + 1
        Dic.Add Tmp, K
        dArr(K, 1) = K
        dArr(K, 3) = Tmp
        dArr(K, 4) = 1
        For N = 1 To UBound(sArr)
            If sArr(N, 3) = Tmp Then
                K = K + 1
                dArr(K, 1) = K
                dArr(K, 2) = sArr(N, 2)
            End If
        Next N
    Else
        dArr(Dic.Item(Tmp), 4) = dArr(Dic.Item(Tmp), 4) + 1
    End If
Next I
    If K Then Range("K7").Resize(K, 4) = dArr
Set Dic = nothing
End Sub

 

[miphp]

Cảm ơn bác hpkhuong nhé. e cũng e cũng vừa thử code của Bác rồi

 

[sealand]

Cảm ơn bácsealand nhé e làm được rồi,

Nếu được thì sửa 1 chút như code sau sẽ bỏ đi hàm Exc và rắc rối thêm vùng.

Sub Thop()
Dim Tm, Kq(), i, j, k, [B][COLOR=#ff0000]Id[/COLOR][/B]
Dim Cl As New Collection
Tm = Sheet1.[B7:D12]
On Error Resume Next
For i = 1 To UBound(Tm, 1)
Cl.Add Tm(i, 3), Tm(i, 3)
If Err.Number <> 0 Then
Err.Clear
Else
k = k + 1
ReDim Preserve Kq(1 To 4, 1 To k)
Kq(1, k) = k
[B][COLOR=#ff0000]Id = k[/COLOR][/B]
Kq(3, k) = Tm(i, 3)
For j = 1 To UBound(Tm, 1)
If Tm(j, 3) = Tm(i, 3) Then
[B][COLOR=#ff0000]Kq(4, Id) = Kq(4, Id) + 1[/COLOR][/B]
k = k + 1
ReDim Preserve Kq(1 To 4, 1 To k)
Kq(1, k) = k
Kq(2, k) = Tm(j, 2)
End If
Next
End If
Next
Sheet1.[F7:I1000].ClearContents
[B][COLOR=#ff0000]if k>0 then [/COLOR][/B]Sheet1.[F7].Resize(k, 4) = WorksheetFunction.Transpose(Kq)
End Sub