Sub clear()
Workbooks("Data.xlsm").Activate
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Select
Cells().clear
With Sheets("temp")
.Visible = True
.Cells().clear
End With
Sheets("FBL1N").Select
Cells().clear
End Sub
Sub xin()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim bottom As Integer, bottom1 As Integer, x As Integer, y As Integer, z As Integer, h As Integer, c As Integer, a As Integer, n As Integer, curr As Integer
Dim arr, arr1, arr2, arr3
Dim amount As Double, amount1 As Double, amount2 As Double, amount3 As Double, amount4 As Double, amount5 As Double, r1 As Double, r2 As Double
Dim EUR_rate As Double, JPY_rate As Double
EUR_rate = Sheets("Macro").Range("B2")
JPY_rate = Sheets("Macro").Range("B3")
a = 0
c = 1
amount = 0
bottom1 = 1
Workbooks.Open Filename:=ThisWorkbook.Path & "/" & "template.xlsx"
Workbooks("Data.xlsm").Activate
Workbooks("Data.xlsm").Activate
Sheets("FBL1N").Select
bottom = Sheets("FBL1N").Cells.Find("*", , , , , xlPrevious).Row
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=3, Criteria1:="="
ActiveSheet.AutoFilter.Range.SpecialCells(12).Copy Sheets("Sheet1").Range("a1")
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=3
Sheets("Sheet1").Select
For curr = 1 To [n65536].End(3).Row
If Range("n" & curr).Value = "JPY" Then
Range("o" & curr).Value = Round(Range("o" & curr) / JPY_rate, 2)
End If
If Range("n" & curr).Value = "EUR" Then
Range("o" & curr).Value = Round(Range("o" & curr) / EUR_rate, 2)
End If
Next
Range("O1").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("O1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:V" & Range("o65536").End(3).Row)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
Selection.Delete shift:=xlUp
arr = Range("o1:o" & Range("o65536").End(3).Row)
arr1 = Range("b1:b" & Range("b65536").End(3).Row)
For y = Range("o65536").End(3).Row To 1 Step -1
If arr(y, 1) < -8000000 Then
amount2 = 0
amount3 = 0
amount4 = 0
amount5 = 0
n = Abs(Int(arr(y, 1) / 8000000))
Sheets("FBL1N").Select
r1 = Sheets("FBL1N").[b:b].Find(arr1(y, 1), Lookat:=xlWhole).Row
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2, Criteria1:=arr1(y, 1), Operator:=xlFilterValues
Rows("1:1").EntireRow.Hidden = True
ActiveSheet.AutoFilter.Range.SpecialCells(12).Copy Sheets("temp").Range("a1")
Workbooks("Data.xlsm").Activate
Sheets("temp").Select
For z = 1 To n
Workbooks("Data.xlsm").Activate
Sheets("temp").Select
arr2 = Range("o1:o" & Range("o65536").End(3).Row - 1)
arr3 = Range("q1:q" & Range("q65536").End(3).Row - 1)
For h = 1 To [o65536].End(3).Row - 1
amount2 = amount2 + arr2(h, 1)
amount3 = amount2 - arr2(h, 1)
amount4 = amount4 + arr3(h, 1)
amount5 = amount4 - arr3(h, 1)
If amount2 < -8000000 Then
Range("a1:v" & h - 1).Copy
Workbooks("template.xlsx").Activate
Sheets("FBL1N").Range("a2").Select
ActiveSheet.Paste
Range("n" & Range("o65536").End(3).Row).Offset(1, 0).Value = Range("n" & Range("o65536").End(3).Row).Value
Range("o" & Range("o65536").End(3).Row).Offset(1, 0).Value = amount3
Range("o" & Range("o65536").End(3).Row).NumberFormatLocal = "#,##0.00_ "
Range("p" & Range("c65536").End(3).Row).Offset(1, 0).Value = Range("p" & Range("c65536").End(3).Row).Value
Range("q" & Range("c65536").End(3).Row).Offset(1, 0).Value = amount5
Range("q" & Range("o65536").End(3).Row).NumberFormatLocal = "#,##0.00_ "
Range("b" & Range("c65536").End(3).Row).Offset(1, 0) = Range("b" & Range("c65536").End(3).Row)
Range(Cells(Range("o65536").End(3).Row, "a"), Cells(Range("o65536").End(3).Row, "v")).Interior.ColorIndex = 6
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "/" & "data" & c & ".xlsx"
Range("a2:v" & Range("o65536").End(3).Row + 1).clear
c = c + 1
Workbooks("Data.xlsm").Activate
Sheets("temp").Select
Rows("1:" & h - 1).Select
Selection.Delete shift:=xlUp
amount2 = 0
amount3 = 0
amount4 = 0
amount5 = 0
Sheets("FBL1N").Select
Range(r1 & ":" & r1 + h - 2).Select
Selection.Delete shift:=xlUp
Exit For
End If
Next
Next
Sheets("Sheet1").Select
Range("o" & y).Value = amount2
Range("q" & y).Value = amount4
Sheets("temp").Select
Cells().clear
Sheets("FBL1N").Select
Rows("1:1").EntireRow.Hidden = False
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2
r2 = Sheets("FBL1N").[b:b].Find(arr1(y, 1), , , , , xlPrevious).Row
Range("o" & r2).Value = amount2
Range("q" & r2).Value = amount4
End If
Next
Sheets("Sheet1").Select
Range("O1").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("O1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:V" & Range("o65536").End(3).Row)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Workbooks("Data.xlsm").Activate
Worksheets("Sheet1").Select
arr = Range("o1:o" & Range("o65536").End(3).Row)
arr1 = Range("b1:b" & Range("b65536").End(3).Row)
For x = 1 To Range("o65536").End(3).Row
amount = amount + arr(1 + a, 1)
If amount >= -8000000 Then
Workbooks("Data.xlsm").Activate
Sheets("FBL1N").Select
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2, Criteria1:=arr1(a + 1, 1), Operator:=xlFilterValues
Rows("1:1").EntireRow.Hidden = True
ActiveSheet.AutoFilter.Range.SpecialCells(12).Copy
Workbooks("template.xlsx").Activate
Sheets("FBL1N").Range("a" & bottom1 + 1).Select
ActiveSheet.Paste
bottom1 = [b65536].End(3).Row
Workbooks("Data.xlsm").Activate
Sheets("FBL1N").Select
Rows("1:1").EntireRow.Hidden = False
Sheets("Sheet1").Select
a = a + 1
amount1 = amount
'str_filt = str_filt & Chr(34) & arr1(2 + a, 1) & Chr(34) & ", "
Else
Workbooks("template.xlsx").Activate
If Application.WorksheetFunction.CountIf(Sheets("FBL1N").Range("c1:c" & [b65536].End(3).Row), "") > 1 Then
Range(Cells(bottom1, "a"), Cells(bottom1, "V")).Copy Range(Cells(bottom1 + 1, "a"), Cells(bottom1 + 1, "V"))
Range(Cells(bottom1 + 1, "o"), Cells(bottom1 + 1, "o")) = amount1
Range(Cells(bottom1 + 1, "p"), Cells(bottom1 + 1, "p")).ClearContents
Range(Cells(bottom1 + 1, "q"), Cells(bottom1 + 1, "q")).ClearContents
Range(Cells(bottom1 + 1, "b"), Cells(bottom1 + 1, "b")).ClearContents
End If
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "/" & "data" & c & ".xlsx"
Range("a2:v" & bottom1 + 1).clear
x = x - 1
' a = a - 1
c = c + 1
bottom1 = 1
amount = 0
amount1 = 0
End If
Next
Workbooks("template.xlsx").Activate
If Range("b2") <> "" Then
Range("a2:v" & [b65536].End(3).Row).ClearContents
End If
Workbooks("template.xlsx").Close True
Workbooks("Data.xlsm").Activate
Sheets("Sheet1").Select
Rows("1:1").Select
Selection.AutoFilter
Cells().clear
ActiveSheet.Visible = False
With Sheets("temp")
.Cells().clear
.Visible = False
End With
Sheets("FBL1N").Select
ActiveSheet.Range("A1:V" & bottom).AutoFilter Field:=2
Rows("1:1").Select
Selection.AutoFilter
Range("A1").Select
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
uj5u.com熱心網友回復：
可以除錯,定位出錯的具體位置,這一堆代碼,估計沒幾人有耐心讀uj5u.com熱心網友回復：
very good!uj5u.com熱心網友回復：
轉到 VBA 論壇去吧。uj5u.com熱心網友回復：
注釋掉所有On Error Resume Next陳述句，在VBA IDE中運行，出錯后點擊除錯，游標會停在出錯的那條陳述句處，
或者
事先在懷疑可能有邏輯錯誤的陳述句處設定斷點，運行經過斷點時中斷，
此時可以在立即視窗中使用
?變數名
或
?函式名(函式引數)
或
程序名(引數)
輔助除錯。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/46867.html
標籤：VBA
下一篇：求代碼