多表数据汇总，谢谢！

Albert128

蓝桥玄霜 发表于 2012-8-27 12:04
请见附件。

{:soso_e183:}再次感谢蓝版，有始有终，诲人不倦，具有典型的大师风范。
当我前几天看到您精华贴《常见字典用法集锦及代码详解》时，发现字典代码里虽然也有许多循环，但是运行速度奇快，于是就下决心学习，来个以猫画虎的学习方式，试作三个账套科目余额表的合并。经过这几天的学习和总结，从开始排序版-修订版1、2、3，在此也要感谢赵刚版主帮助，现在已经到了基本成功版3。
有不妥之处，望指正。Tks a  lot!

蓝桥玄霜

哪怕是以猫画虎，只有自己多动手，才能进步快。
附件设置有密码。

Albert128

蓝桥玄霜 发表于 2012-8-28 09:41
哪怕是以猫画虎，只有自己多动手，才能进步快。
附件设置有密码。

附件密码已经取消，还存在一个问题就是工作表一个都不选的情况下，会出现运行错误提示。

蓝桥玄霜

Private Sub CommandButton1_Click()
    Dim arr, brr(1 To 100000, 1 To 3), i&, j&, m&, l&, t, d As Object, x$, rng As Range
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Range("A2:e2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    With Me.ListView1
        For l = 1 To .ListItems.Count
            If .ListItems(l).Checked = True Then
                arr = Sheets("" & .ListItems(l).Text).[b1].CurrentRegion
                For i = 2 To UBound(arr)
                    x = arr(i, 1) & arr(i, 2)
                    t = d(x)
                    If t = "" Then
                        m = m + 1
                        d(x) = m
                        brr(m, 1) = x
                        brr(m, 2) = arr(i, 10)
                        brr(m, 3) = arr(i, 11)
                        
                Else
                        brr(t, 2) = brr(t, 2) + arr(i, 10)
                        brr(t, 3) = brr(t, 3) + arr(i, 11)
                        
                End If
            Next
        End If
    Next
   End With
   If m = 0 Then MsgBox "不能一个表格都不选择！请选择表格。": Exit Sub
    Range("A2").Resize(m, 3) = brr
   
    drr = [a1].CurrentRegion
    [a2].Resize(UBound(drr) - 1, 3).Sort [a2], 1
    Range("a2:c" & UBound(drr)).Sort Key1:=Range("a2"), Order1:=xlAscending
    For h = 2 To UBound(drr)
        Cells(h, 4) = Left(Cells(h, 1), 4)
        If Not Cells(h, 1).Find("[", , , 2) Is Nothing Then
            Cells(h, 5) = Cells(h, 4) & Application.Text(Application.CountIf _
                          (Range(Cells(2, 4), Cells(h, 4)), Cells(h, 4)), "00")
            Else
            Cells(h, 5) = Cells(h, 4) & "00"
            
        End If
    Next
    [a2].Resize(UBound(drr) - 1, 5).Sort [e2], 1
    [D:E] = ""
   
    Columns("A:A").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        '.TintAndShade = 0
    End With
   
   
    For Each rng In [a1].CurrentRegion
    If Not rng.Find("[", , , 2) Is Nothing Then
        With rng.Characters(Start:=1, Length:=4).Font
            .ColorIndex = 2
            '.ThemeColor = xlThemeColorDark1
        End With
     End If
    Next
   
    Range("A1").Select
    Application.ScreenUpdating = True
    Unload Me
End Sub

蓝桥玄霜

做的不错。
请见附件。

huazai688

{:soso_e100:}{:soso_e100:}

18zhangyong

蓝桥玄霜 发表于 2012-8-28 11:25
做的不错。
请见附件。

版主，打开文件为什么会有这个问题出现？

释释然

太强大了，感谢分享了，应该好好学习下

840205910

有空来学习

hsczq

来这里学习学习啦