求助：用VBA数组求出每种产品近期的消耗量

laojiu369

各位老师：       B列列出近期每天各种产品的消耗量，H1单元格列出了全部产品型号。

       现求助，请用VBA数组（B列一个数组，H1一个数组），求出每种产品近期消耗量。
预谢！

详见附件。
新建 Microsoft Excel 工作表.rar (5.26 KB, 下载次数: 21)

2020-2-12 16:12 上传

点击文件名下载附件

lsdongjh

字典的简单应用，无非涉及字符串的拆分（split）

蓝桥玄霜

消耗量的例子：

鄂龙蒙

1. <blockquote>Sub 统计()

复制代码

鄂龙蒙

请测试：
求出每种产品近期的消耗量.rar (9.87 KB, 下载次数: 4)

2020-2-12 21:48 上传

点击文件名下载附件

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Main()
   
4.     Dim sh As Worksheet, lngRow As Long, arrData As Variant
   
5.     Dim objDic As Object, strKey As String
   
6.     Dim arrKeys As Variant, arrItems As Variant
   
7.    
   
8.     Set sh = Sheets("Sheet1")
   
9.     Set objDic = CreateObject("Scripting.Dictionary")
   
10.     '将型号装入字典，并赋值为0
    
11.     strKey = sh.Range("H1").Value
    
12.     SetDic objDic, strKey
    
13.    
    
14.     '读取产品型号
    
15.     lngRow = sh.Range("B" & Rows.Count).End(xlUp).Row
    
16.     arrData = sh.Range("B2:B" & lngRow)
    
17.    
    
18.     For lngRow = LBound(arrData) To UBound(arrData)
    
19.         strKey = arrData(lngRow, 1)
    
20.         '将产品装入字典，并一次 +1
    
21.         SetDic objDic, strKey, 1
    
22.     Next
    
23.    
    
24.     lngRow = objDic.Count
    
25.     If lngRow > 0 Then
    
26.         arrKeys = objDic.keys
    
27.         arrItems = objDic.Items
    
28.         
    
29.         sh.Range("D:E").Clear
    
30.         sh.Range("D1").Resize(lngRow, 1) = Application.WorksheetFunction.Transpose(arrKeys)
    
31.         sh.Range("E1").Resize(lngRow, 1) = Application.WorksheetFunction.Transpose(arrItems)
    
32.     End If
    
33.    
    
34.     Set objDic = Nothing
    
35.     MsgBox "OK"
    
36. End Sub
    
37. 
    
38. 
    
39. Function SetDic(objDic As Object, strID As String, Optional lngAdd As Long = 0, Optional strChar As String = " ")
    
40.     Dim strSplit() As String, lngID As Long, strKey As String
    
41.    
    
42.     strSplit = Split(strID, strChar)
    
43.    
    
44.     For lngID = LBound(strSplit) To UBound(strSplit)
    
45.         strKey = Trim(strSplit(lngID))
    
46.         If strKey <> "" Then objDic(strKey) = objDic(strKey) + lngAdd
    
47.     Next
    
48. End Function
    

复制代码

sdc3211772

Sub test()
Dim brr(1 To 100, 1 To 2)
arr = Split([h1], " ")
For i = 0 To UBound(arr)
    For j = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If InStr(Cells(j, 2), arr(i)) Then
            n = n + 1
        End If
    Next
    brr(i + 1, 1) = arr(i)
    brr(i + 1, 2) = n
    n = 0
Next
[g2].Resize(UBound(arr) + 1, 2) = brr
End Sub

laojiu369

衷心感谢老版主蓝桥玄霜、鄂龙蒙、lsdongjh、sdc3211772几位老师出手相助，初步试了一下，总的感觉：一个字“爽”，三个字“爽极了”，实在是佩服！向各位学习了！水平有限，需要慢慢消化，再次表示感谢！好人一生平安！

laojiu369

各位老师：
       我又有一个新的想法，如果我想把近期产品消耗在5-8台之间的型号，用空格作间隔，集中显示在某个单元格内，比如H2，代码又应该怎样修改呢？还请各位不吝赐教。

jiangxiaoyun

Sub hh()
    Dim arr, brr(1 To 10000, 1 To 2)
    r = Cells(Rows.Count, 2).End(xlUp).Row
    arr = Range("b2:b" & r).Value
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        s = Split(arr(i, 1), " ")
        For x = 0 To UBound(s)
            If Not d.exists(s(x)) Then
                k = k + 1
                d(s(x)) = k
                brr(k, 1) = s(x)
                brr(k, 2) = 1
            Else
                r = d(s(x))
                brr(r, 2) = brr(r, 2) + 1
            End If
        Next
    Next
    Dim a(1 To 4, 1 To 2)
    For i = 1 To 4
        a(i, 1) = i + 4
    Next
    For i = 1 To 4
        For j = 1 To k
            If brr(j, 2) = a(i, 1) Then a(i, 2) = a(i, 2) & " " & brr(j, 1)
        Next
    Next
    [d2].Resize(4, 2) = a
    [d7].Resize(k, 2) = brr
End Sub