求助：大神，合并同类项，累计求和怎样写代码？

10307951261

怎样写代码，根据《数据录入》的合同单号，达到《单号查询》工作表显示的效果 统一.rar (90.23 KB, 下载次数: 56)

2019-1-17 20:54 上传

点击文件名下载附件

不知道为什么

字典数组可以的

10307951261

不知道为什么 发表于 2019-1-17 20:58
字典数组可以的

本人VBA小白，大神，能不能帮忙写一下

cjc209

参考
Sub 双字典汇统计()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
   
    arr = Sheet21.Range("a3").CurrentRegion '数据装入数组
   
    For i = 4 To UBound(arr)
         tjz = arr(i, 10) '条件
            If d.Exists(tjz) Then '字典里存在的时候
                brr = d(tjz) '字典关键字对应的条目的值装入结果数组（可以为数组）
               If Not d1.Exists(arr(i, 2) & tjz) Then '结果条件
                 brr(2) = brr(2) & "/" & arr(i, 2) '要汇总的列
                 d1(arr(i, 2) & tjz) = "" '结果去重字典
                End If
                If Not d1.Exists(arr(i, 3) & tjz) Then '结果条件
                 brr(5) = brr(5) & "/" & arr(i, 3) '要汇总的列
                 d1(arr(i, 3) & tjz) = "" '结果去重字典
                End If
                 If Not d1.Exists(arr(i, 6) & tjz) Then '结果条件
                 brr(4) = brr(4) & "/" & arr(i, 6) '要汇总的列
                 d1(arr(i, 6) & tjz) = "" '结果去重字典
                End If
                  If Not d1.Exists(arr(i, 7) & tjz) Then '结果条件
                 brr(6) = brr(6) & "/" & arr(i, 7) '要汇总的列
                 d1(arr(i, 7) & tjz) = "" '结果去重字典
                End If
                   If Not d1.Exists(arr(i, 11) & tjz) Then '结果条件
                 brr(9) = brr(9) & "/" & arr(i, 11) '要汇总的列
                 d1(arr(i, 11) & tjz) = "" '结果去重字典
                End If
                    If Not d1.Exists(arr(i, 14) & tjz) Then '结果条件
                 brr(12) = brr(12) & "/" & arr(i, 14) '要汇总的列
                 d1(arr(i, 14) & tjz) = "" '结果去重字典
                End If
               
                brr(7) = brr(7) + arr(i, 8)
                brr(8) = brr(7) + arr(i, 9)
                brr(10) = brr(10) + arr(i, 12)
                brr(11) = brr(11) + arr(i, 13)
            Else
                ReDim brr(1 To 12) '声明动态数组 装符合条件的每列数据
                m = m + 1
                brr(1) = m ' 读取分公司对应的条目 即区域写入数组第一列
                brr(2) = arr(i, 2)
                brr(3) = arr(i, 10)
                brr(4) = arr(i, 6)
                brr(5) = arr(i, 3)
                brr(6) = arr(i, 7)
                brr(7) = arr(i, 8)
                brr(8) = arr(i, 9)
                brr(9) = arr(i, 11)
                brr(10) = arr(i, 12)
                brr(11) = arr(i, 13)
                brr(12) = arr(i, 14)
               
                d1(arr(i, 2) & tjz) = ""
                d1(arr(i, 3) & tjz) = ""
                d1(arr(i, 6) & tjz) = ""
                d1(arr(i, 7) & tjz) = ""
                d1(arr(i, 11) & tjz) = ""
                d1(arr(i, 14) & tjz) = ""
              
            
            End If
            d(tjz) = brr '更新字典条目中的值
    Next
    If d.Count Then
        Sheet1.Range("a2").CurrentRegion.Offset(2).ClearContents '清除结果区的原有数据
        brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items)) '数组装置
        Sheet1.Range("a3").Resize(d.Count, UBound(brr, 2)) = brr '赋值
    Else
        MsgBox "无符合条件的数据"
    End If
End Sub

10307951261

哪位大侠，帮帮忙，真的不会

不知道为什么

10307951261 发表于 2019-1-17 21:03
本人VBA小白，大神，能不能帮忙写一下

如图，供参考

不知道为什么

10307951261 发表于 2019-1-17 21:03
本人VBA小白，大神，能不能帮忙写一下

                       

10307951261

不知道为什么 发表于 2019-1-17 22:57

谢谢大神，先使用后再来学习

10307951261

cjc209 发表于 2019-1-17 21:38
参考
Sub 双字典汇统计()
    Dim arr, brr

谢谢大侠，学习

陕西二蛋

三组代码,合并后各自都能运行,我多次实验过,始终无法完整的运行,跪求各位大神,帮助我修改一下,
1.权限登录窗体代码
Private Sub Workbook_BeforeClose(Cancel AsBoolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save '保存当前工作簿文档
End Sub
Private Sub Workbook_Open()
Application.Visible = 0
login.Show '加载登录窗体
Application.Visible = True
End Sub
2.设定日期 .超出日期自毁代码
Option Explicit
Sub KillThisWorkbook()
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close
End With
End Sub
Private SubWorkbook_Open()
If Date > #2/22/2022# Then
Call KillThisWorkbook
End If
End Sub
3.硬盘序列号,设限使用,非指定用户.文件自毁
Private Declare PtrSafe FunctionGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVallpBuffer As String, nSize As Long) As Long
Private SubWorkbook_Open()
Dim str As String * 100
Dim ovp As Long
Dim cpn As String
ovp = 99
cpn = GetHardDiskInfo(hdPrimaryMaster,hdOnlySN)
If cpn <> "RW103005B6314"Then '你指定的用户
MsgBox "非指定用户，文件将自毁！"
Call Killme
End If
End Sub
Sub Killme()
Application.DisplayAlerts = False
With ActiveWorkbook
.ChangeFileAccess xlReadOnly
Kill .FullName
wbClose_1
End With
End Sub