vba 字典统计求教

LIUZHU · 发表于 2024-6-17 12:39

更正下，厂名+班组为键

LIUZHU · 发表于 2024-6-17 12:39

附件重新上传下

wang-way · 发表于 2024-6-17 12:58

LIUZHU 发表于 2024-6-17 12:35
我以前也喜欢这么用，数据装到字典里面，在转换成数组输出，现在数组当字典用

你更上一层楼，我在后面跟着

taller · 发表于 2024-6-17 13:23

wang-way 发表于 2024-6-16 23:32
版主分组部分是不是写错了 group by 生产厂, 生产班组, 产品等级

为啥错了？代码测试没有问题

wtzxuexivba · 发表于 2024-6-17 15:59

作为论坛新人求助帖，得到各位大神如此关注，对大家深表谢意！再次感谢辛苦付出时间和精力的亲们。解决问题是一方面，但更重要的是在此论坛中学到的解题思路越来越广，知识深度不断增加。谢谢大家！

wang-way · 发表于 2024-6-17 19:27

taller 发表于 2024-6-17 13:23
为啥错了？代码测试没有问题

这里是不是工序？

413254881 · 发表于 2024-6-18 00:58

Option Explicit
Sub t()
Dim arr As Variant, i As Long, k As Long, key1 As Variant, key2 As Variant
arr = ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Value
Dim dic1 As Object: Set dic1 = CreateObject("scripting.dictionary")
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
If arr(i, 4) <> 4 Then
key1 = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
If Not dic1.Exists(key1) Then Set dic1(key1) = CreateObject("Scripting.Dictionary")
dic1(key1)(arr(i, 5)) = dic1(key1)(arr(i, 5)) + arr(i, 6)
End If
Next
Dim brr As Variant: ReDim brr(1 To dic1.Count, 1 To 6)
For Each key1 In dic1.keys
k = k + 1
For i = 1 To 3
brr(k, i) = Split(key1, ",")(i - 1)
Next i
For Each key2 In dic1(key1).keys
Select Case key2
Case "A": brr(k, 4) = dic1(key1)(key2)
Case "B": brr(k, 5) = dic1(key1)(key2)
Case "C": brr(k, 6) = dic1(key1)(key2)
End Select
Next key2
Next key1
ThisWorkbook.ActiveSheet.Range("H2").Resize(10000, UBound(brr, 2)).ClearContents
ThisWorkbook.ActiveSheet.Range("H2").Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
End Sub

复制代码

413254881 · 发表于 2024-6-18 01:04

Option Explicit
Sub t()
Dim arr As Variant, i As Long, k As Long, key1 As Variant, key2 As Variant
arr = ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Value
Dim dic1 As Object: Set dic1 = CreateObject("scripting.dictionary")
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
If arr(i, 4) <> 4 Then
key1 = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
If Not dic1.Exists(key1) Then Set dic1(key1) = CreateObject("Scripting.Dictionary")
dic1(key1)(arr(i, 5)) = dic1(key1)(arr(i, 5)) + arr(i, 6)
End If
Next
Dim brr As Variant: ReDim brr(1 To dic1.Count, 1 To 6)
For Each key1 In dic1.keys
k = k + 1
For i = 1 To 3
brr(k, i) = Split(key1, ",")(i - 1)
Next i
For Each key2 In dic1(key1).keys
Select Case key2
Case "A": brr(k, 4) = dic1(key1)(key2)
Case "B": brr(k, 5) = dic1(key1)(key2)
Case "C": brr(k, 6) = dic1(key1)(key2)
End Select
Next key2
Next key1
ThisWorkbook.ActiveSheet.Range("H2").Resize(10000, UBound(brr, 2)).ClearContents
ThisWorkbook.ActiveSheet.Range("H2").Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
End Sub

复制代码

peteryhr · 发表于 2024-6-18 08:37

Sub byPeteryhr()
Dim i&, j&, jsNum&, s$, arr, brr(), Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dic.Add "A", 4: Dic.Add "B", 5: Dic.Add "C", 6
With Sheet1
      .Range("H1:M" & Cells(Rows.Count, "H").End(xlUp).Row).Offset(1).ClearContents
      arr = [A1].CurrentRegion
      ReDim brr(1 To UBound(arr), 1 To 6)
      For i = 2 To UBound(arr)
         s = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
         If arr(i, 4) <> 4 Then
            If Dic.exists(s) Then
                  brr(Dic(s), Dic(arr(i, 5))) = brr(Dic(s), Dic(arr(i, 5))) + arr(i, 6)
            Else
                  jsNum = jsNum + 1
                  For j = 1 To 3
                     brr(jsNum, j) = arr(i, j + 1)
                  Next
                  brr(jsNum, Dic(arr(i, 5))) = arr(i, 6)
                  Dic(s) = jsNum
            End If
         End If
      Next
      [H2].Resize(UBound(brr), UBound(brr, 2)) = brr
End With
Set Dic = Nothing
End Sub

		自动登录	找回密码
密码			免费注册