Giúp sửa code cộng dồn số lượng theo tên hàng (1 người xem)

[minhtuan55]

Chào cả nhà GPE !
Mình có dùng 1 đoạn Code ( ở trên diễn đàn ) dùng để cộng dồn số lượng theo tên mặt hàng, Code chỉ chạy đúng khi số lượng là số nguyên, còn khi số lượng là số lẻ thì code không chạy đúng được. Mình rất mong mọi người giúp đở mình. Thank

 

[khuongvietphong]

Chào cả nhà GPE !
Mình có dùng 1 đoạn Code ( ở trên diễn đàn ) dùng để cộng dồn số lượng theo tên mặt hàng, Code chỉ chạy đúng khi số lượng là số nguyên, còn khi số lượng là số lẻ thì code không chạy đúng được. Mình rất mong mọi người giúp đở mình. Thank

Thử với File này xem

 

[minhtuan55]

Thử với File này xem

Code của bạn CỘng số lẻ đúng rồi. Nhưng mình hỏi làm sao mình thay đổi được địa chỉ đầu vào ví dụ như B10:B100 thì mình thay làm sao

Sub loc()
Dim i As Long, mang As Variant, dic As Object, chuoi As String, sl As Double, vt As Long
Set dic = CreateObject("Scripting.Dictionary")
mang = Split([B20] & "," & [B21], ",") ' cai nay thay bang B20:B100 thi lam sao
For i = 0 To UBound(mang)
vt = InStr(1, mang(i), "[") - 2
chuoi = LTrim(Left(mang(i), vt))
sl = Val(Mid(mang(i), InStr(1, mang(i), "[") + 1, InStr(1, mang(i), "]") - InStr(1, mang(i), "[") + 1))
If Not dic.exists(chuoi) Then
dic.Add chuoi, sl
Else
dic.Item(chuoi) = dic.Item(chuoi) + sl
End If
[D20].Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
[E20].Resize(dic.Count) = WorksheetFunction.Transpose(dic.Items)


Next i



End Sub

 

[khuongvietphong]

Code của bạn CỘng số lẻ đúng rồi. Nhưng mình hỏi làm sao mình thay đổi được địa chỉ đầu vào ví dụ như B10:B100 thì mình thay làm sao

Bạn thay dòng đỏ bên trên thành 2 dòng này:

chuoi = Join(WorksheetFunction.Transpose(Range("B20:B100")), ",")
mang = Split(chuoi, ",")

 

[minhtuan55]

Anh ơi nó báo lỗi dòng màu đỏ bên dưới và khi dữ liệu đầu vào Trống thì em muốn Đầu ra trống luôn, chứ hiện tại nó vẫn ra . Anh kiểm tra giúp em với

Sub loc()
Dim i As Long, mang As Variant, dic As Object, chuoi As String, sl As Double, vt As Long
Set dic = CreateObject("Scripting.Dictionary")
chuoi = Join(WorksheetFunction.Transpose(Range("B20:B30")), ",")
mang = Split(chuoi, ",")
For i = 0 To UBound(mang)
vt = InStr(1, mang(i), "[") - 2
chuoi = LTrim(Left(mang(i), vt))
sl = Val(Mid(mang(i), InStr(1, mang(i), "[") + 1, InStr(1, mang(i), "]") - InStr(1, mang(i), "[") + 1))
If Not dic.exists(chuoi) Then
dic.Add chuoi, sl
Else
dic.Item(chuoi) = dic.Item(chuoi) + sl
End If
[D20].Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
[E20].Resize(dic.Count) = WorksheetFunction.Transpose(dic.Items)


Next i
End Sub

 

[minhtuan55]

Bạn thay dòng đỏ bên trên thành 2 dòng này:

chuoi = Join(WorksheetFunction.Transpose(Range("B20:B100")), ",")
mang = Split(chuoi, ",")

Anh ơi code của anh chạy rất là chậm khi em thay đổi dử liệu đầu vào từ 1000 dòng trở lên. Chậm hơn rất nhiều Code cũ của em. Giờ anh có thể chỉnh lại Code củ của em làm sao cho cộng được các số Lẻ được không.


Sub LOC()
Dim Dic As Object, objmatch As Object
Dim TmpArr, tmp, Item, ArrSource, ArrResult(1 To 500, 1 To 2), strResult$
Dim i&, j&, n&, TenHang$, Sluong&
Set Dic = CreateObject("scripting.dictionary")
ArrSource = Sheets("data").Range("B20:B1000") ' dau vao Input
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = ",*(.+?)\[\s*(\d+)\s*\]"
For i = 1 To UBound(ArrSource, 1)
tmp = ArrSource(i, 1)
If .test(tmp) Then
Set objmatch = .Execute(tmp)
For Each Item In objmatch
TenHang = Application.Trim(Item.submatches(0))
Sluong = Val(Item.submatches(1))
If Not Dic.Exists(TenHang) Then
j = j + 1
Dic.Add TenHang, j
ArrResult(j, 1) = TenHang
ArrResult(j, 2) = Sluong
Else
n = Dic.Item(TenHang)
ArrResult(n, 2) = Sluong + ArrResult(n, 2)
End If
Next
End If
Next
End With
For i = 1 To j
strResult = strResult & ArrResult(i, 1) & vbTab & ArrResult(i, 2) & vbLf
Next
Sheets("data").Range("D20").Resize(11, 2) = ArrResult 'dau ra Output
Set Dic = Nothing


End Sub