zoukankan      html  css  js  c++  java
  • 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
    

      

  • 相关阅读:
    【题解】「CF1373B」01 Game
    asdfasd
    android开发DialogFragment禁止按back键消失的解决方法
    MySQL报错1055
    IDEA中使用Git拉取代码时报 Git pull failed原因及处理方法
    数据挖掘导论 完整版+PPT+Python R代码
    MATLAB统计分析与应用 40个案例分析[源代码及数据]
    机器学习实战 中英文版
    电力系统负荷预测数据集【全】含下载链接
    Nginx 导致swagger setCookie sessionid 失效
  • 原文地址:https://www.cnblogs.com/nextseven/p/7425633.html
Copyright © 2011-2022 走看看