[已解决]学校账簿设计：信息分解（代码修改或新写代码）

zjdh

Sub 分解()
    Dim d, arr
    Dim i%, j As Byte, k As Byte, iRow%, sh As Object
    Dim brr(1 To 1500, 1 To 15)
    Set d = CreateObject("scripting.dictionary")
    For k = 4 To 8
        Set sh = Sheets(k)
        d(sh.Name) = k
        With Sheets("银行账")
            arr = .Range("A6:O" & .Range("a65536").End(xlUp).Row)
        End With
        For i = 1 To UBound(arr)
            If d(arr(i, 5)) = k Then
                iRow = iRow + 1
                For j = 1 To 15
                    brr(iRow, j) = arr(i, j)
                Next
            End If
        Next
        sh.Select
        Range("A5:O65536").ClearContents
        If iRow > 0 Then
            Range("A5").Resize(iRow, 15) = brr
            Range("A6:M" & Range("A65536").End(3).Row).Sort Key1:=Range("A5"), _
                 Order1:=xlAscending, Key2:=Range("B5"), Order2:=xlAscending, Header:=xlGuess
            With Range("A6:O" & Range("A65536").End(3).Row).Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = 15
            End With
        End If
        Set sh = Nothing
        iRow = 0
        Erase brr
    Next
End Sub

龙送农

zjdh 发表于 2014-4-17 08:41
Sub 分解()
    Dim d, arr
    Dim i%, j As Byte, k As Byte, iRow%, sh As Object

谢谢老师！