[已解决]谢谢liuguansky老师,汇总求助

lhj323323

p7amr7os.rar (64.52 KB, 下载次数: 1)

2010-12-9 18:30 上传

点击文件名下载附件
[求助]汇总求助

老师:

到目前为止,我只做成了提取不重复值导入到结果表中,但是这个汇总表却老是不成功.随附上论坛几位老师用于其它需求的程序,以作为参考,无奈理解能力差了,莫法,请老师帮助,谢谢.

[此贴子已经被作者于2010-12-10 13:20:18编辑过]

最佳答案

月排行榜 / 总排行榜

liuguansky

2010-12-10 12:41

Sub justsoso()
    Dim dic, dic1, arr, i&, arrt(), k&
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    dic1.Add "本币", 0
    dic1.Add "外币", 9
    arr = [b3:j3]
    For i = 1 To UBound(arr, 2)
        dic1.Add arr(1, i), i
    Next i
    arr = Sheet11.Range("a1:l" & Sheet11.Cells(Rows.Count, 2).End(3).Row).Value
    For i = 2 To UBound(arr, 1)
        If arr(i, 8) <> "" Then
            If dic.exists(arr(i, 8)) Then
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) = arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 11)
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)) + 18, dic(arr(i, 8))) = arrt(18 + dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 12)
                Else: k = k + 1: ReDim Preserve arrt(1 To 36, 1 To k): dic.Add arr(i, 8), k

                    arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), k) = arr(i, 11)
                    arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)) + 18, k) = arr(i, 12)

            End If
        End If
    Next
    Rows("4:" & Rows.Count).ClearContents
    Cells(4, 1).Resize(k, 1) = Application.Transpose(dic.keys)
    Cells(4, 2).Resize(k, 36) = Application.Transpose(arrt)
    Set dic = Nothing
End Sub
不好意思，漏了一段代码。 IDGD8lHX.rar (46.33 KB, 下载次数: 17)

2010-12-10 12:41 上传

点击文件名下载附件
[求助]汇总求助

跳转到最佳答案楼层

lhj323323

求助

liuguansky

Sub justsoso()
    Dim dic, dic1, arr, i&, arrt(), k&
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    dic1.Add "本币", 0
    dic1.Add "外币", 9
    arr = [b3:j3]
    For i = 1 To UBound(arr, 2)
        dic1.Add arr(1, i), i
    Next i
    arr = Sheet11.Range("a1:l" & Sheet11.Cells(Rows.Count, 2).End(3).Row).Value
    For i = 2 To UBound(arr, 1)
        If arr(i, 8) <> "" Then
            If dic.exists(arr(i, 8)) Then
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) = arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 11)
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)) + 20, dic(arr(i, 8))) = arrt(20 + dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 12)
                Else: k = k + 1: ReDim Preserve arrt(1 To 40, 1 To k): dic.Add arr(i, 8), k
            End If
        End If
    Next
    Rows("4:" & Rows.Count).ClearContents
    Cells(4, 1).Resize(k, 1) = Application.Transpose(dic.keys)
    Cells(4, 2).Resize(k, 40) = Application.Transpose(arrt)
    Set dic = Nothing
End Sub 35SJeS0g.rar (46.13 KB, 下载次数: 4)

2010-12-10 09:43 上传

点击文件名下载附件
[求助]汇总求助

lhj323323

liuguansky老师:

在数据源[全辖数据库]的K\L列的金额合计为1140854958

在结果表[表六]的金额合计为1124466219

好像结果表导入的数据不够

liuguansky

Sub justsoso()
    Dim dic, dic1, arr, i&, arrt(), k&
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    dic1.Add "本币", 0
    dic1.Add "外币", 9
    arr = [b3:j3]
    For i = 1 To UBound(arr, 2)
        dic1.Add arr(1, i), i
    Next i
    arr = Sheet11.Range("a1:l" & Sheet11.Cells(Rows.Count, 2).End(3).Row).Value
    For i = 2 To UBound(arr, 1)
        If arr(i, 8) <> "" Then
            If dic.exists(arr(i, 8)) Then
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) = arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 11)
                arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)) + 18, dic(arr(i, 8))) = arrt(18 + dic1(arr(i, 6)) + dic1(arr(i, 2)), dic(arr(i, 8))) + arr(i, 12)
                Else: k = k + 1: ReDim Preserve arrt(1 To 36, 1 To k): dic.Add arr(i, 8), k

                    arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)), k) = arr(i, 11)
                    arrt(dic1(arr(i, 6)) + dic1(arr(i, 2)) + 18, k) = arr(i, 12)

            End If
        End If
    Next
    Rows("4:" & Rows.Count).ClearContents
    Cells(4, 1).Resize(k, 1) = Application.Transpose(dic.keys)
    Cells(4, 2).Resize(k, 36) = Application.Transpose(arrt)
    Set dic = Nothing
End Sub
不好意思，漏了一段代码。 IDGD8lHX.rar (46.33 KB, 下载次数: 17)

2010-12-10 12:41 上传

点击文件名下载附件
[求助]汇总求助

simonguo

学习下