Excel 產生 資產負債表 & 損益表 (三) --- 日記帳的資料處理

    在這個章節，我們要開始著重如何進行日記帳的初步處理，而會計科目會是賁張的重點。它會包含：

1. "會計科目" 的排序。

2. "會計科目" 的正確性檢查。

3. 以個別 "會計科目" 建立 T 型帳戶工作頁。

下面是這章節的完整程式碼 (包含在 Sub DailyAccount() 程序中)：

====================================================

Sub DailyAccount()

Dim I As Integer, J As Integer
Dim SheetName As String
Dim AddSheet As Boolean
Dim SubjectName As String
 
 ' 日記帳資料處理
 ' 先作編號
 Sheets("會計科目").Select
 Sheets("日記帳").Select
 MainLastRow = Sheets("日記帳").Cells(60000, 1).End(xlUp).Row
 For I = 2 To MainLastRow
  Sheets("日記帳").Cells(I, 9) = I
 Next I
 
 '寫入精簡會計科目公式
 Range("J2").Select
 Selection.Formula = "=IF(C2<>"""",  TRIM(C2), TRIM(D2))"
 Selection.AutoFill Destination:=Range("J2:J" & MainLastRow & ""), Type:=xlFillDefault
   
 '以會計科目及憑單號數排序
 Range(Sheets("日記帳").Cells(2, 1), Sheets("日記帳").Cells(MainLastRow, 10)).Select
 Selection.Sort Key1:=Range(Sheets("日記帳").Cells(2, 10), Sheets("日記帳").Cells(2, 10)), Order1:=xlAscending, _
                Key2:=Range(Sheets("日記帳").Cells(2, 2), Sheets("日記帳").Cells(2, 2)), Order1:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' 判斷是否新增工作頁
 For I = 1 To MainLastRow - 1
  If Trim(Sheets("日記帳").Cells(I, 10)) <> Trim(Sheets("日記帳").Cells(I + 1, 10)) Then
  ' 檢查會計科目
  Sheets("會計科目").Select
  Find_Macro (Trim(Sheets("日記帳").Cells(I + 1, 3)))
  If (FindObj Is Nothing) = True Then
   MsgBox (Trim(Sheets("日記帳").Cells(I + 1, 3)) & ": 會計科目有誤")
   'Exit For
  End If
   
   AddSheet = True
   For J = 1 To Sheets.Count
    If Trim(Sheets("日記帳").Cells(I + 1, 3)) = Sheets(J).Name Or Trim(Sheets("日記帳").Cells(I + 1, 4)) = Sheets(J).Name Then
     AddSheet = False
     Exit For
    End If
   Next J
   
   If AddSheet = True Then
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Select
    If Trim(Sheets("日記帳").Cells(I + 1, 3)) <> "" Then
      SubjectName = Trim(Sheets("日記帳").Cells(I + 1, 3))
    Else
      SubjectName = Trim(Sheets("日記帳").Cells(I + 1, 4))
    End If
    
    Sheets(Sheets.Count).Name = SubjectName
    Sheets("格式").Select
    Cells.Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    ActiveSheet.Paste
    Sheets(Sheets.Count).Cells(1, 1) = SubjectName
   End If
   
  End If
 Next I
 
End Sub

====================================================

程式碼解釋如下：

第一段：蒐集會計科目，並列於 I 欄，已準備做排序用

Sheets("日記帳").Select
 MainLastRow = Sheets("日記帳").Cells(60000, 1).End(xlUp).Row
 For I = 2 To MainLastRow
  Sheets("日記帳").Cells(I, 9) = I
 Next I

第二段：蒐集會計科目，並列於 I 欄，已準備做排序用

'寫入精簡會計科目公式
 Range("J2").Select
 Selection.Formula = "=IF(C2<>"""",  TRIM(C2), TRIM(D2))"
 Selection.AutoFill Destination:=Range("J2:J" & MainLastRow & ""), Type:=xlFillDefault

第三段：會計科目排序，相同會計科目排在一起

'以會計科目及憑單號數排序
 Range(Sheets("日記帳").Cells(2, 1), Sheets("日記帳").Cells(MainLastRow, 10)).Select
 Selection.Sort Key1:=Range(Sheets("日記帳").Cells(2, 10), Sheets("日記帳").Cells(2, 10)), Order1:=xlAscending, _
                Key2:=Range(Sheets("日記帳").Cells(2, 2), Sheets("日記帳").Cells(2, 2)), Order1:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

第四段：檢查會計科目是否正確，如果錯誤，彈出警告視窗。如果沒有問題，輸出 T 型帳戶

' 判斷是否新增工作頁
 For I = 1 To MainLastRow - 1
  If Trim(Sheets("日記帳").Cells(I, 10)) <> Trim(Sheets("日記帳").Cells(I + 1, 10)) Then
  ' 檢查會計科目
  Sheets("會計科目").Select
  Find_Macro (Trim(Sheets("日記帳").Cells(I + 1, 3)))
  If (FindObj Is Nothing) = True Then
   MsgBox (Trim(Sheets("日記帳").Cells(I + 1, 3)) & ": 會計科目有誤")
   'Exit For
  End If
   
   AddSheet = True
   For J = 1 To Sheets.Count
    If Trim(Sheets("日記帳").Cells(I + 1, 3)) = Sheets(J).Name Or Trim(Sheets("日記帳").Cells(I + 1, 4)) = Sheets(J).Name Then
     AddSheet = False
     Exit For
    End If
   Next J
   
   If AddSheet = True Then
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Select
    If Trim(Sheets("日記帳").Cells(I + 1, 3)) <> "" Then
      SubjectName = Trim(Sheets("日記帳").Cells(I + 1, 3))
    Else
      SubjectName = Trim(Sheets("日記帳").Cells(I + 1, 4))
    End If
    
    Sheets(Sheets.Count).Name = SubjectName
    Sheets("格式").Select
    Cells.Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    ActiveSheet.Paste
    Sheets(Sheets.Count).Cells(1, 1) = SubjectName
   End If
   
  End If
 Next I