VBA 矩阵统计 ( 有难度 )

On_fire

VBA 矩阵统计 ( 有难度)

*

Sheet1是源资料,

第一行是标题行,A列是标题列,行列数是变量及不固定

*

代码逻辑,

分别输出,标题行及标题列的矩阵,

同时,分别统计及累加每一行及一列的数值(注: 累加一对标题对应的最小值 )

*

模拟了部分的结果, 在Rows及Columns页

比如在Rows页,

4 & 11的矩阵=4,

因为B列1, 加上E列3 ( = 1+3 =4)

比如在Columns页,

A & B的矩阵=7,

因为第2行的4, 加上第12行的1, 加上第20行的2 ( = 4+1+2= 7 )

*

数据N多, 有难度, 请大神, 老师出手帮忙...

chxw68

1. Sub test1()
   
2.   Dim r%, i%, j%, c%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8.   End With
   
9.   ReDim brr(1 To UBound(arr), 1 To UBound(arr))
   
10.   For i = 1 To UBound(arr)
    
11.     brr(i, 1) = arr(i, 1)
    
12.     brr(1, i) = arr(i, 1)
    
13.   Next
    
14.   For i = 2 To UBound(arr)
    
15.     For j = 2 To UBound(arr)
    
16.       If i <> j Then
    
17.         For k = 2 To UBound(arr, 2)
    
18.           brr(i, j) = brr(i, j) + Application.Min(arr(i, k), arr(j, k))
    
19.         Next
    
20.       Else
    
21.         brr(i, j) = 1
    
22.       End If
    
23.     Next
    
24.   Next
    
25.   For i = 2 To UBound(brr)
    
26.     For j = 2 To UBound(brr, 2)
    
27.       If brr(i, j) = 0 Then
    
28.         brr(i, j) = Empty
    
29.       End If
    
30.     Next
    
31.   Next
    
32.   With Worksheets("rows")
    
33.     .Cells.Clear
    
34.     .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
35.   End With
    
36. End Sub
    

复制代码

chxw68

1. Sub test2()
   
2.   Dim r%, i%, j%, c%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8.   End With
   
9.   ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 2))
   
10.   For j = 1 To UBound(arr, 2)
    
11.     brr(1, j) = arr(1, j)
    
12.     brr(j, 1) = arr(1, j)
    
13.   Next
    
14.   For i = 2 To UBound(arr, 2)
    
15.     For j = 2 To UBound(arr, 2)
    
16.       If i <> j Then
    
17.         For k = 2 To UBound(arr)
    
18.           brr(i, j) = brr(i, j) + Application.Min(arr(k, i), arr(k, j))
    
19.         Next
    
20.       Else
    
21.         brr(i, j) = 1
    
22.       End If
    
23.     Next
    
24.   Next
    
25.   For i = 2 To UBound(brr)
    
26.     For j = 2 To UBound(brr, 2)
    
27.       If brr(i, j) = 0 Then
    
28.         brr(i, j) = Empty
    
29.       End If
    
30.     Next
    
31.   Next
    
32.   With Worksheets("columns")
    
33.     .Cells.Clear
    
34.     .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
35.   End With
    
36. End Sub
    
37. 
    

复制代码

chxw68

问题不难，但理解太难！

On_fire

chxw68 发表于 2021-10-2 13:07
问题不难，但理解太难！

谢谢褚老师,

是您厉害,
啥难题都难不到你…