|
|
楼主 |
发表于 2018-7-6 14:22
|
显示全部楼层
自己摸索着改了下，可还是不能运行啊，有点晕，麻烦老师们抽出宝贵的时间给看一下哈，先谢谢了。
'Option Explicit
Sub 生成流水账()
Dim arr As Variant, brr() As Variant, d As Object, theWb As Workbook
Dim i&, j&, k&, theTempValue As Variant, theNumStr$, theName$, theStr$
Dim thePath$, theTemplateFullName$, sht As Variant, theRecordsCount&
Dim theCountryName$, theGroupName$, theSheetsCount&, theOldSheetsInNewWorkbook&
arr = Sheet4.Cells(1).CurrentRegion
For i = 5 To UBound(arr) - 1 '冒泡排序(升序)
For j = 2 To UBound(arr) - 1
If arr(j, 2) > arr(j + 1, 2) Then
For k = 1 To UBound(arr, 2)
theTempValue = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = theTempValue
Next k
End If
Next j
Next i
ReDim brr(5 To 100, 1 To 13) '5至100行，1到13列；数组范围
thePath = ThisWorkbook.Path
If Right(thePath, 1) <> "\" Then thePath = thePath & "\"
theTemplateFullName = thePath & Sheet5.Name & ".xls"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheet5.Copy
With ActiveWorkbook
.SaveAs Filename:=theTemplateFullName, FileFormat:=xlTemplate
.Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set d = CreateObject("Scripting.Dictionary")
For i = 5 To UBound(arr)
theName = arr(i, 2) '同一分包人
If theName <> "" Then d(theName) = ""
Next i
If d.Count = 0 Then GoTo The_Exit
Application.ScreenUpdating = False
Application.ShowWindowsInTaskbar = False
i = 2
For j = 0 To d.Count - 1
theName = d.keys()(j)
theCountryName = ""
theGroupName = ""
theNumStr = ""
theRecordsCount = 0
Do While arr(i, 2) = theName
theRecordsCount = theRecordsCount + 1
If theCountryName = "" Then theCountryName = Split(arr(i, 1), ":")(0) '项目名称
If theGroupName = "" Then theGroupName = Replace(Split(arr(i, 1), ":")(1), ":", "") '项目名称内容
If theNumStr = "" Then theNumStr = arr(i, 2)
brr(theRecordsCount, 1) = arr(i, 1) '合同名称
brr(theRecordsCount, 2) = arr(i, 3) '科目
brr(theRecordsCount, 3) = arr(i, 4) '除税金额
brr(theRecordsCount, 4) = arr(i, 5) '税金
brr(theRecordsCount, 5) = arr(i, 5) '支付日期
brr(theRecordsCount, 6) = arr(i, 6) '支付金额
brr(theRecordsCount, 7) = arr(i, 7) '支付比例
brr(theRecordsCount, 8) = arr(i, 10) '收款单位
brr(theRecordsCount, 9) = arr(i, 12) '备注
If i > UBound(arr) Then Exit Do
Loop
If theRecordsCount > 0 Then
theSheetsCount = theSheetsCount + 1
If Not theWb Is Nothing Then
Application.DisplayAlerts = False
With theWb
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count), Type:=theTemplateFullName)
End With
Application.DisplayAlerts = True
Else
theOldSheetsInNewWorkbook = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set theWb = Workbooks.Add
Application.SheetsInNewWorkbook = theOldSheetsInNewWorkbook
With theWb
Application.DisplayAlerts = False
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count), Type:=theTemplateFullName)
.Worksheets(1).Delete
Application.DisplayAlerts = True
End With
End If
With sht
.Name = theName
.Cells(2, 1) = theCountryName '项目名称位置
.Cells(2, 2) = theGroupName '项目名称内容位置
.Cells(2, 7) = theNumStr '分包人内容位置
.Cells(5, 1).Resize(theRecordsCount, UBound(brr, 2)) = brr '开始写入内容位置
End With
End If
Application.ShowWindowsInTaskbar = True
If theSheetsCount > 0 Then
theWb.Worksheets(1).Activate
Application.ScreenUpdating = True
MsgBox "工作簿文件已生成", vbInformation, "信息"
Else
Application.ScreenUpdating = True
MsgBox "未生成工作簿文件", vbInformation, "信息"
End If
The_Exit:
On Error Resume Next
Kill theTemplateFullName
On Error GoTo 0
Set sht = Nothing
Set d = Nothing
Set theWb = Nothing
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-7-5 10:57
