Hì biết là dùng dic được, nhưng vì Dic của mình đang ở căn bản, mà bài này tổng hợp theo cả tiêu đề cột và dòng nên chưa biết thuật toán làm sao
Bài toán có nhiều phương án giải, nhưng vì em đang học code nên muốn giải bằng code
Tôi không tin một người có trình độ như bạn lại sợ nói chuyện với sếp về vấn đề này.
Nếu tôi là bạn thì tôi tìm thử xem có cách nào dùng Power Query để chuẩn lại cái bảng dữ liệu kia.
Bạn thử.Nhưng chưa chuẩn lắm tự bạn sửa tiếp nhé.
Sub tinhtong()
Dim arr, i As Long, dk As String, lr As String, dic As Object, j As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
arr = .Range("A3:D20").Value
End With
For i = 2 To UBound(arr)
If arr(i, 2) <> Empty Then
dk = arr(i, 1) & arr(i, 2) & arr(1, 2)
Else
dk = arr(i, 1) & arr(i, 3) & arr(1, 3)
End If
If Not dic.exists(dk) Then
dic.Add dk, arr(i, 4)
Else
dic.Item(dk) = dic.Item(dk) + arr(i, 4)
End If
Next i
With Sheets("kq")
.Range("b5:i11").ClearContents
arr = .Range("A3:I11").Value
For j = 2 To UBound(arr, 2)
If arr(1, j) = Empty Then arr(1, j) = arr(1, j - 1)
For i = 3 To UBound(arr)
dk = arr(1, j) & arr(i, 1) & arr(2, j)
arr(i, j) = dic.Item(dk)
Next i
Next j
.Range("A3:I11").Value = arr
End With
End SubDòng này hình như không để làm gì thì phải
À, do mình không để ý dữ liệu thiếu trong sheet KQ, bạn đã lấp đầy dữ liệu thiếu bằng dòng code đó rồi
Dựa bài toán trên , em đã lấp đầy cột B và C của sheet Data = các ký tự khác
Sub tinhtong1()
Dim arr, i As Long, dk As String, lr As String, dic As Object, j As Long
Dim arrT, d As Long ' thêm
Dim arrTT, n As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
arrT = .Range("A3", .Range("A65000").End(3)).Resize(, 4).Value
End With
arrTT = Range([A5], [A65000].End(3)).Value
For n = 1 To UBound(arrTT)
For d = 2 To UBound(arrT)
If arrT(d, 2) = arrTT(n, 1) Then
dk = arrT(d, 1) & arrTT(n, 1) & arrT(1, 2)
End If
If arrT(d, 3) = arrTT(n, 1) Then
dk = arrT(d, 1) & arrTT(n, 1) & arrT(1, 3)
End If
If Not dic.exists(dk) Then
dic.Add dk, arrT(d, 4)
Else
dic.Item(dk) = dic.Item(dk) + arrT(d, 4)
End If
Next
Next
With Sheets("kq")
.Range("b5:k11").ClearContents
arr = .Range("A3:k11").Value
For j = 2 To UBound(arr, 2)
'If arr(1, j) = Empty Then arr(1, j) = arr(1, j - 1)
For i = 3 To UBound(arr)
dk = arr(1, j) & arr(i, 1) & arr(2, j)
arr(i, j) = dic.Item(dk)
Next i
Next j
.Range("A3:k11").Value = arr
'Range("A3").Resize(i - 1, j - 1).Value = arr
End With
End SubBạn viết code nhìn khá là rối
dk = arrT(d, 1) & arrTT(n, 1) & arrT(1, 2)(1) đúng rồi
Bạn tham khảo code này
Sub tinhtong()
Dim arr, i As Long, dk As String, dic As Object, j As Long, lr As Long, dk1 As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
lr = .Range("A10000").End(xlUp).Row
arr = .Range("A3:D" & lr).Value
End With
For i = 2 To UBound(arr)
dk = arr(i, 1) & arr(i, 2) & arr(1, 2)
dk1 = arr(i, 1) & arr(i, 3) & arr(1, 3)
If Not dic.exists(dk) Then
dic.Add dk, arr(i, 4)
Else
dic.Item(dk) = dic.Item(dk) + arr(i, 4)
End If
If Not dic.exists(dk1) Then
dic.Add dk1, arr(i, 4)
Else
dic.Item(dk1) = dic.Item(dk1) + arr(i, 4)
End If
Next i
With Sheets("kq")
lr = .Range("A10000").End(xlUp).Row
.Range("B5:K" & lr).ClearContents
arr = .Range("A3:K" & lr).Value
For j = 2 To UBound(arr, 2)
If arr(1, j) = Empty Then arr(1, j) = arr(1, j - 1)
For i = 3 To UBound(arr)
dk = arr(1, j) & arr(i, 1) & arr(2, j)
arr(i, j) = dic.Item(dk)
Next i
Next j
.Range("A3:K" & lr).Value = arr
End With
End Sub
