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
