- Sub test()
- '年度分析，開銷前3名
- Application.ScreenUpdating = False
- W = [W]
- r = [A1].CurrentRegion.Rows.Count
- Range("B7:M" & r).ClearContents
- Range("B2:M3").ClearContents
- myyear = [A1].Value
- For c = 2 To 13
- mymonth = myyear & "/" & Trim(Cells(1, c).Value)
- income = 0
- expense = 0
- pay = 0
- v = 11
- With Sheets("DataCopy")
- er = .[A100000].End(3).Row
- For r = 2 To er
- If myyear & "/" & Format(.Cells(r, 1).Value, "m月份") = mymonth Then
- money = Val(.Cells(r, 3).Value)
- Select Case .Cells(r, 2).Value
- Case "收入": income = income + money
- Case "支出": expense = expense + money
- Case "分期付款": expense = expense + money: pay = pay + 1
- End Select
- myitem = .Cells(r, 4).Value
- If .Cells(r, 2).Value <> "收入" Then
- Set cell = Columns(c + 1).Find(myitem)
- If Not cell Is Nothing Then
- cell.Offset(, -1).Value = cell.Offset(, -1).Value + money
- Else
- Cells(v, c).Value = money
- Cells(v, c + 1).Value = .Cells(r, 4).Value
- v = v + 1
- End If
- End If
- End If
- Next r
- If Cells(11, c) <> "" Then
- Set rng = Range(Cells(11, c), Cells(v - 1, c + 1))
- rng.Sort key1:=Cells(11, c), order1:=xlDescending
- X = 0
- v = 11
- Do Until Cells(v, c).Value = ""
- If InStr(W, Cells(v, c + 1)) = 0 Then
- If X < 3 Then
- X = X + 1
- Cells(X + 6, c).Value = X & ". " & Cells(v, c + 1).Value & " / " & Cells(v, c).Value & "元"
- End If
- End If
- Cells(v, c).Value = v - 10 & ". " & Cells(v, c + 1).Value & " / " & Cells(v, c).Value & "元"
- Cells(v, c + 1).Value = ""
- v = v + 1
- Loop
- End If
- End With
- Cells(2, c).Value = IIf(income <> 0, income, "")
- Cells(3, c).Value = IIf(expense <> 0, expense, "")
- Cells(10, c).Value = pay
- Next c
- Application.ScreenUpdating = True
- '自動換行
- Rows("7:100000").EntireRow.AutoFit
- Application.ScreenUpdating = True
- End Sub
換成2010後，執行以後會變得非常非常的慢，不知道有沒有辦法改善，謝謝！ |
發表於 2015-4-21 19:16
| 
