20170824xlVBA出车对账单

Private Sub GetClientAccountList()
    Dim EndRow As Long
    Dim i As Long, j As Long
    Dim m As Long, n As Long
    Dim TakeSum As Double, PaySum As Double
    Dim NotTake As Double, NotPay As Double
    Dim HasTake As Double, HasPay As Double
    Dim FileName As String
    Dim FolderPath As String
    Dim FilePath As String
    Dim Rng As Range
    Dim Arr As Variant
    Dim Brr(), iRows

    Dim Crr()
    ReDim Crr(1 To 4, 1 To 1)
    Index = 0

    Const HeadRow As Long = 1
    Dim NewSht As Worksheet
    Dim Wb As Workbook
    Dim NewWb As Workbook
    Dim Sht As Worksheet

    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & "\先达对账单\"
    Dim dClient As Object
    Dim dTrade As Object
    Set dClient = CreateObject("Scripting.Dictionary")
    Set dTrade = CreateObject("Scripting.Dictionary")
    Set Sht = Wb.Worksheets("明细")
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:T" & EndRow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            Key = CStr(Arr(i, 1))
            If Key <> "" Then dClient(Key) = dClient(Key) & i & ";"
            Key = CStr(Arr(i, 11))
            If Key <> "" Then dTrade(Key) = dTrade(Key) & i & ";"
        Next i
    End With
    Count = 0
    For Each onekey In dClient.Keys
        If Not dTrade.exists(onekey) Then
            ''''————————————————————————————
            NotTake = 0
            '单纯客户

            Set NewWb = Application.Workbooks.Add
            FileName = onekey & "--先达 2017对账单"
            FilePath = FolderPath & FileName & ".xlsx"
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
            Set NewSht = NewWb.Worksheets(1)
            NewSht.Name = FileName

            With NewSht
                .Cells.Clear
                With .Range("A1:J1")
                    .Value = Array("客户", "日期", "行程", "车型", "记账RMB", "记账HK", "现收RMB", "现收HK", "先达应收", "先达应付")
                    .Font.Bold = True
                    With .Interior
                        .Pattern = xlSolid
                        .Color = 16763443
                    End With
                End With
                iRows = Split(dClient(onekey), ";")
                RowCount = UBound(iRows)
                'Debug.Print RowCount
                ReDim Brr(1 To RowCount, 1 To 12)
                m = 0
                For i = LBound(iRows) To UBound(iRows) - 1
                    m = m + 1
                    For j = 1 To 8
                        Brr(m, j) = Arr(iRows(i), j)
                    Next j
                    Brr(m, 9) = Brr(m, 5) + Brr(m, 6) - Brr(m, 7) - Brr(m, 8)
                    NotTake = NotTake + Brr(m, 9)
                Next i
                .Range("A2").Resize(RowCount, 10).Value = Brr
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row

                desrow = EndRow + 1
                .Cells(desrow, "I").Value = NotTake
                .Cells(desrow + 1, "I").Value = NotTake
                .Cells(desrow + 1, "I").Resize(1, 2).Merge
                .Cells(desrow + 1, "C").Value = "合计"
                SetBorders .UsedRange
                SetCenters .UsedRange
                .UsedRange.WrapText = True
                .UsedRange.Columns.AutoFit
                .UsedRange.Rows(1).RowHeight = 20
                .UsedRange.Range("A:A").ColumnWidth = 10
                .UsedRange.Range("B:B").ColumnWidth = 8
                .UsedRange.Range("D:D").ColumnWidth = 6
                .UsedRange.Range("E:J").ColumnWidth = 9
                .UsedRange.Range("E:E,G:G,I:J").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                '.UsedRange.Range("G:G").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                .UsedRange.Range("F:F,H:H").NumberFormat = "\$#,##0;-\$#,##0"
                '.UsedRange.Range("H:H").NumberFormat = "\$#,##0;-\$#,##0"
                '.UsedRange.Range("I:J").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                .UsedRange.Columns(3).ColumnWidth = 40
                 .UsedRange.Columns(3).HorizontalAlignment = xlLeft
                .Range("C65536").End(xlUp).HorizontalAlignment = xlCenter
                SetCenters .Range("C1")
            End With
            NewWb.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            NewWb.Close True
            Index = Index + 1
            ReDim Preserve Crr(1 To 4, 1 To Index)
            Crr(1, Index) = onekey '公司名称
            Crr(2, Index) = NotTake
            Crr(3, Index) = 0
            Crr(4, Index) = NotTake
        Else
            ''''————————————————————————————
            NotTake = 0
            NotPay = 0

            '同行客户
            Set NewWb = Application.Workbooks.Add
            FileName = onekey & "--先达 2017对账单"
            FilePath = FolderPath & FileName & ".xlsx"
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0
            Set NewSht = NewWb.Worksheets(1)
            NewSht.Name = FileName
            With NewSht
                .Cells.Clear
                With .Range("A1:J1")
                    .Value = Array("客户", "日期", "行程", "车型", "记账RMB", "记账HK", "现收RMB", "现收HK", "先达应收", "先达应付")
                    .Font.Bold = True
                    With .Interior
                        .Pattern = xlSolid
                        .Color = 16763443
                    End With
                End With
                iRows = Split(dClient(onekey), ";")
                RowCount = UBound(iRows)
                'Debug.Print RowCount
                ReDim Brr(1 To RowCount, 1 To 12)
                m = 0
                For i = LBound(iRows) To UBound(iRows) - 1
                    m = m + 1
                    For j = 1 To 8
                        Brr(m, j) = Arr(iRows(i), j)
                    Next j
                    Brr(m, 9) = Brr(m, 5) + Brr(m, 6) - Brr(m, 7) - Brr(m, 8)
                    NotTake = NotTake + Brr(m, 9)
                Next i
                .Range("A2").Resize(RowCount, 10).Value = Brr

                '空一行
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 2
                ''''————————————————————————————

                '外调同行
                iRows = Split(dTrade(onekey), ";")
                RowCount = UBound(iRows)
                'Debug.Print RowCount
                ReDim Brr(1 To RowCount, 1 To 12)
                m = 0
                For i = LBound(iRows) To UBound(iRows) - 1
                    m = m + 1
                    Brr(m, 1) = "先达"
                    For j = 2 To 4
                        Brr(m, j) = Arr(iRows(i), j)
                    Next j
                    For j = 5 To 8
                        Brr(m, j) = Arr(iRows(i), j + 7)
                    Next j

                    Brr(m, 10) = Brr(m, 5) + Brr(m, 6) - Brr(m, 7) - Brr(m, 8)
                    NotPay = NotPay + Brr(m, 10)

                Next i
                .Range("A" & EndRow).Resize(RowCount, 10).Value = Brr
                '空一行
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1

                desrow = EndRow + 1

                .Cells(desrow, "I").Value = NotTake
                .Cells(desrow, "J").Value = NotPay

                .Cells(desrow + 1, "I").Value = NotTake - NotPay
                .Cells(desrow + 1, "I").Resize(1, 2).Merge

                .Cells(desrow + 1, "C").Value = "合计"

                SetBorders .UsedRange
                SetCenters .UsedRange
                .UsedRange.WrapText = True
                .UsedRange.Columns.AutoFit
                .UsedRange.Rows(1).RowHeight = 20
                .UsedRange.Range("A:A").ColumnWidth = 10
                .UsedRange.Range("B:B").ColumnWidth = 8
                .UsedRange.Range("D:D").ColumnWidth = 6
                .UsedRange.Range("E:J").ColumnWidth = 9
                .UsedRange.Range("E:E,G:G,I:J").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                '.UsedRange.Range("G:G").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                .UsedRange.Range("F:F,H:H").NumberFormat = "\$#,##0;-\$#,##0"
                '.UsedRange.Range("H:H").NumberFormat = "\$#,##0;-\$#,##0"
                '.UsedRange.Range("I:J").NumberFormat = """￥""#,##0;[Red]""￥""-#,##0"
                .UsedRange.Columns(3).ColumnWidth = 40
                 .UsedRange.Columns(3).HorizontalAlignment = xlLeft
                .Range("C65536").End(xlUp).HorizontalAlignment = xlCenter
                SetCenters .Range("C1")
            End With

            NewWb.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            NewWb.Close True

            Index = Index + 1
            ReDim Preserve Crr(1 To 4, 1 To Index)
            Crr(1, Index) = onekey '公司名称
            Crr(2, Index) = NotTake
            Crr(3, Index) = NotPay
            Crr(4, Index) = NotTake - NotPay

        End If
        'If Count = 1 Then Exit For
    Next onekey

    For Each onekey In dTrade.Keys
        If Not dTrade.exists(onekey) Then
            Debug.Print "仅同行"; onekey
        End If
    Next onekey

    Set Sht = Wb.Worksheets("账单汇总")
    With Sht
        .UsedRange.Offset(1).Clear
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(UBound(Crr, 2), UBound(Crr))
        Rng.Value = Application.WorksheetFunction.Transpose(Crr)
        SetBorders .UsedRange
        SetCenters .UsedRange
        .UsedRange.Columns.AutoFit
    End With

    Set Wb = Nothing
    Set NewWb = Nothing
    Set Sht = Nothing
    Set NewSht = Nothing
    Set Rng = Nothing

    Set dClient = Nothing
    Set dTrade = Nothing

End Sub
Public Sub SetBorders(ByVal Rng As Range)
    With Rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Public Sub SetCenters(ByVal Rng As Range)
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub