二维数组赋值错 求改正

jerry3770

二维数组赋值错 求改正 谢谢

小凡、、、

quqiyuan

参与一下，仅供参考，我认为问题比较多，供你参考吧。。。

quqiyuan

代码如下。。。。
Sub HHHHH()
    With Sheet2
        .[G4:M1040000] = ""
        Set d = CreateObject("Scripting.Dictionary")
        Dim i As Long
        arr = Worksheets("物料收发汇总表").Range("b2:e" & Worksheets("物料收发汇总表").Range("b1040000").End(xlUp).Row)
        ReDim brr(1 To Worksheets("物料收发汇总表").Range("b1040000").End(xlUp).Row - 1, 1 To 7)
        crr = .Range("g3:m3").Value
        drr = .Range("a4:a7")
        For i = 1 To UBound(drr)
            If drr(i, 1) <> Empty Then d(drr(i, 1)) = i
        Next
        For i = 1 To UBound(arr)
            If d.exists(arr(i, 1)) Then
                m = d(arr(i, 1))
                If arr(i, 4) = crr(1, 1) Then
                    brr(m, 1) = brr(m, 1) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 2) Then
                    brr(m, 2) = brr(m, 2) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 3) Then
                    brr(m, 3) = brr(m, 3) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 4) Then
                    brr(m, 4) = brr(m, 4) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 5) Then
                    brr(m, 5) = brr(m, 5) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 6) Then
                    brr(m, 6) = brr(m, 6) + arr(i, 3)
                ElseIf arr(i, 4) = crr(1, 7) Then
                    brr(m, 7) = brr(m, 7) + arr(i, 3)
                End If
            End If
        Next
        .Range("g4:m" & d.Count + 3) = brr 'WorksheetFunction.Transpose(brr)
    End With
    Set d = Nothing
    Beep
End Sub

Qs18

1. Sub qs()
   
2.     Dim arr, i, dic, brr, sm, j, s, ss
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion.Value
   
5.         For i = 2 To UBound(arr)
   
6.             s = arr(i, 2) & arr(i, 5)
   
7.             If Not dic.exists(s) Then
   
8.                 dic(s) = arr(i, 4)
   
9.             Else
   
10.                 dic(s) = dic(s) + arr(i, 4)
    
11.             End If
    
12.         Next
    
13.     With Sheet2
    
14.         brr = .Range("a1").CurrentRegion.Value
    
15.         For i = 4 To UBound(brr)
    
16.             sm = 0
    
17.             For cl = 2 To UBound(brr, 2) - 1
    
18.                 ss = brr(i, 1) & brr(3, cl)
    
19.                 If dic.exists(ss) Then
    
20.                     brr(i, cl) = dic(ss)
    
21.                 End If
    
22.                 sm = sm + brr(i, cl)
    
23.             Next
    
24.         brr(i, UBound(brr, 2)) = sm
    
25.         Next
    
26.         .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
27.     End With
    
28. End Sub

复制代码

Qs18

试试。。。。。

Qs18

试试，按自己的理解写的

quqiyuan

jerry3770

quqiyuan 发表于 2024-9-12 18:04

谢谢老师  够简洁！！等明天上班我再来学习。

jerry3770

quqiyuan 发表于 2024-9-12 17:53
代码如下。。。。
Sub HHHHH()
    With Sheet2

谢谢老师  我验证下。