Tính Tổng kũy kế bằng Dic
- Thread starter shnhatha@
- Ngày gửi
Bạn thử code sau:
Mã:
Option Explicit
Sub LuyKe()
Dim dict As Object, data As Variant, ma As Variant
Dim r As Long, quantity As Long
Dim sheet As Worksheet, rng As Range
Set sheet = ThisWorkbook.Worksheets("Sheet1")
r = sheet.Cells(sheet.Rows.Count, "D").End(xlUp).Row
If r < 5 Then Exit Sub
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Set rng = sheet.Range("D5:F" & r)
data = rng.Value
For r = LBound(data, 1) To UBound(data, 1)
ma = data(r, 1)
quantity = data(r, 2)
If Not dict.Exists(ma) Then
dict.Add ma, quantity
data(r, 3) = quantity
Else
dict.Item(ma) = dict.Item(ma) + quantity
data(r, 3) = dict.Item(ma)
End If
Next r
rng.Value = data
End SubCảm ơn bạn rất nhiều..!Mình viết một đoạn code như sau để lấy giá trị trùng duy nhất sang một cột khác .Bạn có thể kết hợp 2 đoạn code vào làm 1 giúp mình ..
Xin lỗi vì sự bất tiện.Mình đang tìm hiểu từng chút về Dic nên vẫn chưa hiểu được nhiều và sâu..Xin được học hỏi và mong anh,chị,em thông cảm !
Mã:
Sub Count_If()
Dim lr As Integer, i As Long, k As Long, arr_N(), kq()
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
lr = Sheet1.Range("D" & Rows.Count).End(xlUp).Row
arr_N = Range("D4:D" & lr).Value
ReDim kq(1 To UBound(arr_N, 1), 1 To 1)
k = 0
For i = 1 To UBound(arr_N, 1)
If Not dic.exists(arr_N(i, 1)) Then
dic.Add arr_N(i, 1), k
kq(i, 1) = arr_N(i, 1)
Else
kq(i, 1) = ""
End If
Next
Sheet1.Range("F5:F100").ClearContents
Sheet1.Range("F4").Resize(i - 1, 1) = kq
End Sub
Mình thấy không cần sử dụng Dic khi cột Mã hàng đã được sắp xếp:
Mã:
Sub LuyKe2()
Dim data As Variant, result As Variant, ma As Variant, preMa As Variant
Dim r As Long, quantity As Long
Dim sheet As Worksheet, rng As Range
Set sheet = ThisWorkbook.Worksheets("Sheet1")
r = sheet.Cells(sheet.Rows.Count, "D").End(xlUp).Row
If r < 5 Then Exit Sub
Set rng = sheet.Range("D5:E" & r)
data = rng.Value
ReDim result(1 To UBound(data, 1), 1 To UBound(data, 2))
preMa = vbNullString
For r = LBound(data, 1) To UBound(data, 1)
ma = data(r, 1)
quantity = data(r, 2)
If ma <> preMa Then
preMa = ma
result(r, 1) = ma
result(r, 2) = quantity
Else
result(r, 2) = result(r - 1, 2) + quantity
End If
Next r
rng.Offset(, 2).Resize(r - 1).Value = result
End SubCảm ơn bạn rất nhiều...
Mình có chút nhờ bạn giải thích giúp mình "preMa = vbNullString" mình không hiểu nghĩa câu lệnh đó? Với câu lệch <rng.Offset(, 2).Resize(r - 1).Value = result>
để dán kết quả tại 2 cột liền nhau..!vậy khi mình muốn kết quả được dán vào những cột khác nhau có thể sửa đổi như thế nào vậy?
Bạn tham khảo thêm:
Mã:
Sub LuyKe3()
Dim data As Variant, resMa As Variant, resQty As Variant, ma As Variant, preMa As Variant
Dim r As Long, quantity As Long, sheet As Worksheet, rng As Range
Set sheet = ThisWorkbook.Worksheets("Sheet1")
r = sheet.Cells(sheet.Rows.Count, "D").End(xlUp).Row
If r < 5 Then Exit Sub
Set rng = sheet.Range("D5:E" & r)
data = rng.Value
ReDim resMa(1 To UBound(data, 1), 1 To 1)
ReDim resQty(1 To UBound(data, 1), 1 To 1)
'preMa = vbNullString 'Giá trị ban đầu preMa là rỗng, không cần dòng này cũng được.
For r = LBound(data, 1) To UBound(data, 1)
ma = data(r, 1)
quantity = data(r, 2)
If ma <> preMa Then
preMa = ma
resMa(r, 1) = ma
resQty(r, 1) = quantity
Else
resQty(r, 1) = resQty(r - 1, 1) + quantity
End If
Next r
'Kết quả:
sheet.Range("F5").Resize(r - 1).Value = resMa 'cột mã
sheet.Range("G5").Resize(r - 1).Value = resQty 'cột số lượng
End Sub