希望表里的内容求和做成图片的样子

网海遨游

还有一种思路，有多少列，引用多少次字典。
Ic=ubound(arr,2)-1'列数(排除第一列)
dim d(1 to Ic)
for i=1 to Ic
set d(i)=createobject("scripting.dictionary")
next i
for k=1 to Ic
for j=2 to ubound(arr)
d(k)(arr(j,1))=d(k)(arr(j,1))+(arr(j,k+1))
next j
next k
手机回复，这是思路。睡午觉去……

hihigh

Sub text()
    Dim arr, brr()
   
    Dim r As Integer, c As Integer
   
    Dim i As Integer, j As Integer
   
    Dim d As Object, dk As String，dkk As String
   
    Sheets("sheet2").Cells.Clear

    Set dr = CreateObject("Scripting.Dictionary")
    Set dc = CreateObject("Scripting.Dictionary")
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheets("sheet1").[a1].CurrentRegion.Value
    i = 1
    j = 1
    For r = 2 To UBound(arr)
   
        If Not dr.exists(arr(r, 1)) Then
        
        i = i + 1
        
        dr(arr(r, 1)) = i
        
        End If

        For c = 2 To UBound(arr, 2)
        
            If Not dc.exists(arr(1, c)) Then
            
            j = j + 1
            
            dc(arr(1, c)) = j
            
            End If

            dk = arr(r, 1) & "|" & arr(1, c)
            
            d(dk) = Val(d(dk)) + Val(arr(r, c))
   
        Next c
        
    Next r
   
   Sheets("sheet2").[a2].Resize(dr.Count, 1) = Application.Transpose(dr.keys)
   Sheets("sheet2").[b1].Resize(1, dc.Count) = Application.Transpose(Application.Transpose(dc.keys))
   arr = Sheets("sheet2").[a1].CurrentRegion.Value

    ReDim brr(2 To UBound(arr), 2 To UBound(arr, 2))

    For r = 2 To UBound(arr)

        For c = 2 To UBound(arr, 2)

            dkk = arr(r, 1) & "|" & arr(1, c)

            brr(r, c) = d(dkk)
        Next c
    Next r
    Sheets("sheet2").[b2].Resize(UBound(brr) - 1, UBound(brr, 2) - 1) = brr

End Sub

hihigh

仅 供 参 考

MaTch-

网海遨游 发表于 2019-8-2 13:16
还有一种思路，有多少列，引用多少次字典。
Ic=ubound(arr,2)-1'列数(排除第一列)
dim d(1 to Ic)

非常感谢，我后来用自己的方法也做出来了。

MaTch-

hihigh 发表于 2019-8-2 14:37
Sub text()
    Dim arr, brr()
   

非常感谢，我刚刚已经用自己的方法做出来了

网海遨游

Sub test1()'列可以增加
        Dim sh1 As Worksheet, sh2 As Worksheet
        Dim arr As Variant, d(), i%,j%,Ic%,k%,x%
       Set sh1 = Sheets("sheet1")
       Set sh2 = Sheets("sheet2")
       sh2.Cells.Clear
       sh1.[a1:h1].Copy sh2.[a1]
        arr = sh1.[a1].CurrentRegion
        Ic = UBound(arr, 2) - 1 '列数(排除第一列)
        ReDim d(1 To Ic)
        For i = 1 To Ic
                Set d(i) = CreateObject("scripting.dictionary")
        Next i
        For k = 1 To Ic
                For j = 2 To UBound(arr)
                        d(k)(arr(j, 1)) = d(k)(arr(j, 1)) + (arr(j, k + 1))
                Next j
        Next k
        sh2.[a2].Resize(d(1).Count) = Application.Transpose(d(1).keys)
        For x = 1 To Ic
                sh2.Cells(2, x + 1).Resize(d(1).Count) = Application.Transpose(d(x).items)
        Next x
        sh2.Activate
End Sub

网海遨游

楼主：也请你把你自己做也来的代码，分享下。

MaTch-

网海遨游 发表于 2019-8-2 15:46
楼主：也请你把你自己做也来的代码，分享下。

我应该是在你的基础上，用的一种方法，有些部分可以优化。


Sub test()
Dim sh1, sh2 As Worksheet
Dim arr, brr, crr, d, dic, drr
Dim i, j, s, k, l, m
        Set sh1 = Sheets("sheet1")
       Set sh2 = Sheets("sheet2")
       sh2.Cells.Clear
       sh1.Rows("1:1").Copy sh2.[a1]
       Set d = CreateObject("scripting.dictionary")
       Set dic = CreateObject("scripting.dictionary")
        arr = sh1.[a1].CurrentRegion
      For i = 2 To UBound(arr, 1)
             dic(arr(i, 1)) = ""
            For j = 2 To UBound(arr, 2)
                    s = arr(i, 1) & arr(1, j)
                    d(s) = arr(i, j) + d(s)
            Next
    Next
    brr = dic.keys
    Set dic = Nothing
    sh2.Cells(2, 1).Resize(UBound(brr) + 1, 1) = Application.Transpose(brr)
    sh2.[dd1].Resize(d.Count, 2) = Application.Transpose(Array(d, keys, d.items))
    drr = sh2.[dd1].CurrentRegion  '字典存到数组，可以循环读入数组
    crr = sh2.[a1].CurrentRegion
     For k = 2 To UBound(crr, 1)
        For l = 2 To UBound(crr, 2)
           For m = 1 To UBound(drr, 1)
              If arr(k, 1) & crr(1, l) = drr(m, 1) Then
                        sh2.Cells(k, l) = drr(m, 2)
              End If
           Next
        Next
     Next
     sh2.[dd1].CurrentRegion
     MsgBox "完成！！！"
End Sub

wdx223

用PowerQuery只需要几步就可以实现

MaTch-

wdx223 发表于 2019-8-2 16:44
用PowerQuery只需要几步就可以实现

我用分组依据做的话有好几十列， 也有些费劲，M语言还不会，所以就VBA做一下好了。回头试一下你的，今天的花送没了，下次如果记得再给你评分。谢谢！