[已解决]信息分解就代码中断运行问题

龙送农

这是fffox 帮写的代码，中间“寄宿生生活费”表暂时没有信息，分解就中断了，后面的表分解不到信息。我想要的效果是：进一步优化代码，使代码运行不中断，如中间的表暂时无信息，也能分解后边表的信息。

最佳答案

月排行榜 / 总排行榜

爱疯

2015-1-10 15:30

(, 下载次数: 5)

上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

方便查看

爱疯

Sub 分解()
    Dim d, arr
    Dim i%, j As Byte, k As Byte, iRow%, sh As Object
    Dim brr(1 To 100, 1 To 9)
    Set d = CreateObject("scripting.dictionary")
    For k = 3 To 7       'Sheets.Count
        Set sh = Sheets(k)
        'If sh.Name <> "银行存款日记账" And sh.Name <> "现金日记账" Then
        d(sh.Name) = k
        With Sheets("银行存款日记账")
            arr = .Range("a6:i" & .Range("a65536").End(xlUp).Row)
        End With
        For i = 1 To UBound(arr)
            If d(arr(i, 4)) = k Then
                iRow = iRow + 1
                For j = 1 To 9
                    brr(iRow, j) = arr(i, j)
                Next
            End If
        Next
        With Sheets("现金日记账")
            arr = .Range("a6:i" & .Range("a65536").End(xlUp).Row)
        End With
        For i = 1 To UBound(arr)
            If d(arr(i, 4)) = k Then
                iRow = iRow + 1
                For j = 1 To 9
                    brr(iRow, j) = arr(i, j)
                Next
            End If
        Next
        sh.Range("a6").Resize(iRow, 9) = brr
        Set sh = Nothing
        iRow = 0
        Erase brr
        'End If
    Next
End Sub



这是1楼代码，什么都没改。
只为睡觉时，再看

爱疯

Dim d, B(1 To 100, 1 To 9), s

Sub test1()
    Application.ScreenUpdating = False
    A = Array("银行存款日记账", "现金日记账")
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To Sheets.Count
        Sheets(i).Select
        sh = Sheets(i).Name
        If sh <> A(0) And sh <> A(1) Then
            d(sh) = i
            For j = 0 To UBound(A)
                Call test2(sh, i)
            Next j
            If s Then
                Range("a6:i65536").Clear
                Range("a6").Resize(s, 9) = B
                '复制格式
                Range("a5:l5").Copy
                Range("a6").Resize(s, 12).PasteSpecial (xlPasteFormats)
                Application.CutCopyMode = xlNone
                Range("a6").Select
            End If
        End If
    Next
End Sub

Private Sub test2(sh, k)
    A = Range("a6:i" & Range("a65536").End(xlUp).Row)
    s = 0: Erase B
    For i = 1 To UBound(A)
        If d(A(i, 4)) = k Then
            s = s + 1
            For j = 1 To UBound(B, 2)
                B(s, j) = A(i, j)
            Next
        End If
    Next
End Sub
信息分解(代码优化)2.rar (20.99 KB, 下载次数: 4)

2015-1-9 10:15 上传

点击文件名下载附件 只是整理了下

龙送农

高手过来看看，怎么实现使代码运行不中断，如中间的表暂时无信息，也能分解后边表的信息。

龙送农

{:1112:}自己顶上去

爱疯

信息分解(代码优化)3.rar (21.64 KB, 下载次数: 9)

2015-1-9 23:16 上传

点击文件名下载附件

龙送农

爱疯 发表于 2015-1-9 23:16

老师，我的表变成这样，代码修改那里？
Dim B(1 To 10000, 1 To 9), s

Sub test1()
    Application.ScreenUpdating = False
    A = Array("银行账", "现金账")    '指定表

    For i = 1 To Sheets.Count
        sh = Sheets(i).Name
        '如果是其它表
        If sh <> A(0) And sh <> A(1) Then
            '就用指定表a(j)，筛选出是当前表的数据
            For j = 0 To UBound(A)
                Call test2(A(j), sh)    '参数1是指定表，参数2是当前表
            Next j
            If s Then
                Sheets(i).Select
                Range("a6:i65536").Clear
                Range("a6").Resize(s, 15) = B

                '复制格式
                Range("a5:l5").Copy
                Range("a6").Resize(s, 15).PasteSpecial (xlPasteFormats)
                Application.CutCopyMode = xlNone
                Range("a6").Select
            End If
            s = 0: Erase B
        End If
    Next
End Sub

Private Sub test2(x, y)
    Sheets(x).Select
    A = Range("a6:i" & Range("a65536").End(xlUp).Row)    'A临时保存指定表
    For i = 1 To UBound(A)
        If A(i, 5) = y Then
            s = s + 1
            For j = 1 To UBound(B, 2)
                B(s, j) = A(i, j)
            Next
        End If
    Next
End Sub

爱疯

从8楼起，数据的位置都变了，当然出错。
为方便别人理解，测试和回复你的问题，应尽量上传附件。

龙送农

爱疯 发表于 2015-1-10 12:18
从8楼起，数据的位置都变了，当然出错。
为方便别人理解，测试和回复你的问题，应尽量上传附件。

好，谢谢老师指教！