Công thức cho cell C3:
=SUMPRODUCT(($H$15:$H$22=C$1)*($I$15:$I$22=C$2)*($J$13:$L$13=$A3)*($J$14:$L$14=$B3)*($J$15:$L$22))
VBA thì chắc làm được rồi, nhưng bạn không nói rõ vùng nào khoảng 20000 dòng, 100 cột. Dữ liệu bố trí như vậy thì vùng Kết quả 100 cột và vùng dữ liệu gốc cũng 100 cột thì sao được, bạn lại nói bố trí không khoa học nhưng không thể thay đổi Format thì làm sao đây?
Vậy thì bạn tự kiểm tra và tự chỉnh lại cho vừa ý nhé, tôi cũng "tối con mắt" rồi.
Public Sub ToTiTe()
Dim Rng1(), Rng2(), Arr(), Arr2(), Dic1 As Object, Dic2 As Object, D1 As Long, D2 As Long, I As Long, J As Long
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheet1
Rng1 = .Range(.[J13], .[IV13].End(xlToLeft)).Resize(2).Value
Rng2 = .Range(.[H15], .[H65000].End(xlUp)).Resize(, UBound(Rng1, 2) + 2).Value
ReDim Arr(1 To UBound(Rng1, 2) + 2, 1 To UBound(Rng2, 1))
ReDim Arr2(1 To 2, 1 To UBound(Rng2, 1) + 2)
For I = 1 To UBound(Rng1, 2)
If Not Dic1.Exists(Rng1(1, I) & Rng1(2, I)) Then
D1 = D1 + 1
Dic1.Add Rng1(1, I) & Rng1(1, I), D1
Arr(D1, 1) = Rng1(1, I): Arr(D1, 2) = Rng1(2, I)
End If
Next I
For I = 1 To UBound(Rng2, 1)
If Not Dic2.Exists(Rng2(I, 1) & Rng2(I, 2)) Then
D2 = D2 + 1
Dic2.Add (Rng2(I, 1) & Rng2(I, 2)), D2
Arr2(1, D2) = Rng2(I, 1): Arr2(2, D2) = Rng2(I, 2)
For J = 3 To UBound(Rng2, 2)
Arr(J - 2, D2 + 2) = Rng2(I, J)
Next J
Else
For J = 3 To UBound(Rng2, 2)
Arr(J - 2, Dic2.Item(Rng2(I, 1) & Rng2(I, 2)) + 2) = Arr(J - 2, Dic2.Item(Rng2(I, 1) & Rng2(I, 2)) + 2) + Rng2(I, J)
Next J
End If
Next I
.[C1].Resize(2, D2).Value = Arr2
.[A3].Resize(D1, D2 + 2).Value = Arr
End With
Set Dic1 = Nothing
Set Dic2 = Nothing
End Sub
Sẵn trớn, góp với Ba Tê một cái cho dzui
Public Sub Gom()
Dim VungHang, VungCot, d, I, Mg(), Gom, K, kK, TieuDe(), J
Set d = CreateObject("scripting.dictionary")
Set VungCot = Range([J13], [J13].End(xlToRight)).Resize(2)
VungHang = Range([H15], [H50000].End(xlUp)).Resize(, VungCot.Columns.Count + 2)
For I = 1 To UBound(VungHang)
Gom = VungHang(I, 1) & VungHang(I, 2)
If Not d.exists(Gom) Then
K = K + 1
d.Add Gom, K
ReDim Preserve TieuDe(1 To 2, 1 To d.Count)
TieuDe(1, d.Count) = VungHang(I, 1): TieuDe(2, d.Count) = VungHang(I, 2)
ReDim Preserve Mg(1 To VungCot.Columns.Count, 1 To d.Count)
For J = 1 To VungCot.Columns.Count
Mg(J, d.Count) = VungHang(I, J + 2)
Next J
Else
kK = d.Item(Gom)
For J = 1 To VungCot.Columns.Count
Mg(J, kK) = Mg(J, kK) + VungHang(I, J + 2)
Next J
End If
Next I
[A3].Resize(VungCot.Columns.Count, 2) = Application.WorksheetFunction.Transpose(VungCot)
[C1].Resize(2, d.Count) = TieuDe
[C3].Resize(VungCot.Columns.Count, d.Count) = Mg
End SubPublic Sub Gom2()
Dim VungHang, VungCot, d, I, Mg(), Gom, kK, TieuDe(), J, m, n
Set VungCot = Range([J13], [J13].End(xlToRight)).Resize(2)
n = VungCot.Columns.Count
VungHang = Range([H15], [H50000].End(xlUp)).Resize(, n + 2)
Set d = CreateObject("scripting.dictionary")
For I = 1 To UBound(VungHang)
Gom = VungHang(I, 1) & "#" & VungHang(I, 2)
If Not d.exists(Gom) Then
m = m + 1
d.Add Gom, m
ReDim Preserve TieuDe(1 To 2, 1 To m): ReDim Preserve Mg(1 To n, 1 To m)
TieuDe(1, m) = VungHang(I, 1): TieuDe(2, m) = VungHang(I, 2)
kK = m
Else
kK = d.Item(Gom)
End If
For J = 1 To n
Mg(J, kK) = Mg(J, kK) + VungHang(I, J + 2)
Next J
Next I
With [A1]
.Offset(2).Resize(n, 2) = Application.WorksheetFunction.Transpose(VungCot)
.Offset(, 2).Resize(2, m) = TieuDe
.Offset(2, 2).Resize(n, m) = Mg
End With
End Sub"Bị" Cò Già bắt giò, ít hơn 1 Đít-xông, "Gáng" trợn con mắt "mần" lại cũng 1 Đít-xông-cà-gy xem sao.
Public Sub ToTiTe()
Dim Rng1(), Rng2(), Arr(), Dic As Object, I As Long, J As Long, Cot As Long, Dong As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Rng1 = Range([J13], [J13].End(xlToRight)).Resize(2).Value
Rng2 = Range([H15], [H65000].End(xlUp)).Resize(, UBound(Rng1, 2) + 2).Value
ReDim Arr(1 To UBound(Rng1, 2) + 2, 1 To UBound(Rng2, 1))
Cot = 2
For Dong = 1 To UBound(Rng1, 2)
Arr(Dong + 2, 1) = Rng1(1, Dong): Arr(Dong + 2, 2) = Rng1(2, Dong)
Next Dong
For I = 1 To UBound(Rng2, 1)
Tem = Rng2(I, 1) & Rng2(I, 2)
If Not Dic.Exists(Tem) Then
Cot = Cot + 1
Dic.Add (Tem), Cot
Arr(1, Cot) = Rng2(I, 1): Arr(2, Cot) = Rng2(I, 2)
For J = 3 To UBound(Rng2, 2)
Arr(J, Cot) = Rng2(I, J)
Next J
Else
For J = 3 To UBound(Rng2, 2)
Arr(J, Dic.Item(Tem)) = Arr(J, Dic.Item(Tem)) + Rng2(I, J)
Next J
End If
Next I
[A1].Resize(Dong + 1, Cot).Value = Arr
Set Dic = Nothing
End Sub
Sub cong()
Dim dl, kq(), i, j, k, dk, d As Object
Set d = CreateObject("scripting.dictionary")
dl = Range([H13], [H65536].End(3)).Resize(, 5).Value
ReDim kq(1 To UBound(dl), 1 To 5)
k = 2
For i = 3 To UBound(dl)
dk = dl(i, 1) & dl(i, 2)
If Not d.exists(dk) Then
k = k + 1: d.Add dk, k
kq(k, 1) = dl(i, 1): kq(k, 2) = dl(i, 2)
For j = 3 To 5
kq(k, j) = dl(i, j)
kq(1, j) = dl(1, j)
kq(2, j) = dl(2, j)
Next
Else
For j = 3 To 5
kq(d.Item(dk), j) = kq(d.Item(dk), j) + dl(i, j)
Next
End If
Next
[a1].Resize(j - 1, i - 1) = Application.Transpose(kq)
End Sub Public Sub ToTiTe()
Dim aRg(), Arr(), Dic As Object, Tem As String
Dim I As Long, J As Long, nCR As Long, Cot As Long
With [H13]
aRg = Range(.Offset(0), .Offset(, 2).End(xlToRight)) _
.Resize(.Offset(65000 - .Row).End(xlUp).Row - .Row + 1).Value
End With
nCR = UBound(aRg, 2): ReDim Arr(1 To nCR, 1 To 2)
For J = 3 To nCR
Arr(J, 1) = aRg(1, J): Arr(J, 2) = aRg(2, J)
Next J
Cot = 2: Set Dic = CreateObject("Scripting.Dictionary")
For I = 3 To UBound(aRg, 1)
Tem = aRg(I, 1) & aRg(I, 2) ''hoac = aRg(I, 1) & "#" & aRg(I, 2)
If Dic.Exists(Tem) Then
For J = 3 To nCR
Arr(J, Dic.Item(Tem)) = Arr(J, Dic.Item(Tem)) + aRg(I, J)
Next J
Else
Cot = Cot + 1: Dic.Add (Tem), Cot
ReDim Preserve Arr(1 To nCR, 1 To Cot)
For J = 1 To nCR
Arr(J, Cot) = aRg(I, J)
Next J
End If
Next I
Set Dic = Nothing
[A1].Resize(nCR, Cot).Value = Arr
End SubSub TaoKQ()
Dim mySQL$
Dim Cnn As New ADODB.Connection
Dim Rcs As New ADODB.Recordset
Dim Arr()
strPath = ThisWorkbook.FullName
Set Cnn = New ADODB.Connection
'Tao Ket noi voi file du lieu nguon:'
Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & ";Persist Security Info=False;" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
'---------------------------------------------------------------------------
mySQL = "SELECT f1, F2, sum(f3), sum(f4), sum(f5) FROM [DATA]" & Chr(10)
mySQL = mySQL & "group by f1, f2 " & Chr(10)
Rcs.Open mySQL, Cnn, adOpenKeyset, adLockOptimistic
Arr = Rcs.GetRows
'Gan vao sh'
With Sheets("tmp")
.Cells.ClearContents
.[A3].Resize(Range("Header").Columns.Count, Range("Header").Rows.Count) = Application.WorksheetFunction.Transpose(Range("Header"))
.[C1].Resize(UBound(Arr) + 1, UBound(Arr, 2) + 1) = Arr
End With
'Refresh lai hai bien cnEx va Rcs:'
Rcs.Close: Set Rcs = Nothing
Cnn.Close: Set Cnn = Nothing
Erase Arr
End Sub
Hic, quả thật anh áp dụng rất linh hoạt. Em phải học anh nhiều chứ đâu mà học em.
