エクセルVBAで困っています。
エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。
ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の３つでした。その項目を９つに増やしたいと思っています。又、全てのSheetで１行目には銀行名や項目名を入れたいので２行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で（適当ですが）挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。
Option Explicit
Sub Teller()
'【考え方】Sheet1とSheet2を入力と考える。
'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。
Const BankName1 As String = "○銀行"
Const BankName2 As String = "(チェック)銀行"
Const tempSheet As String = "一時シート"
Dim classify(9) As String
Dim title(5) As String
Dim i As Long
Dim j As Long
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim findUpper As Long
Dim findLower As Long
Dim keyword As String
Dim ws As Worksheet
Dim Bank1 As Worksheet
Dim Bank2 As Worksheet
Dim Temp As Worksheet
Set Bank1 = Worksheets(BankName1)
Set Bank2 = Worksheets(BankName2)
'【振り分ける項目名】
classify(1) = "会費"
classify(2) = "会議費"
classify(3) = "事務費"
classify(4) = "事業費"
classify(5) = "研修費"
classify(6) = "報償費"
classify(7) = "慶弔費"
classify(8) = "予備費"
classify(9) = "積立金"
'【1行目に記載する見出し】
title(1) = "日付"
title(2) = "内容"
title(3) = "収入"
title(4) = "支出"
title(5) = "残高"
'画面更新を停止
Application.ScreenUpdating = False
'最終行取得
Bank1.Select
lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row
Bank2.Select
lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row
'シートを作る
For i = 1 To 3
Call MakeNewSheet_As_ThisName(classify(i))
For j = 1 To 5
Cells(1, j) = title(j)
Next j
Next i
Call MakeNewSheet_As_ThisName(tempSheet)
Cells.ClearContents
Set Temp = Worksheets(tempSheet)
'一時シートに、銀行1のデータと銀行2のデータをコピーする。
Bank1.Select
Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy
Temp.Select
Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial
Bank2.Select
Range(Cells(3, 1), Cells(lastRow2, 5)).Copy
Temp.Select
Cells(lastRow1 - 1, 1).PasteSpecial
'ソートする。
'第一優先キー：B列。[項目]昇順。
'第二優先キー：A列。[日付]昇順。
Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select
With ActiveWorkbook.Worksheets(tempSheet).Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー
.SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー
.SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4))
.Apply
End With
For i = 1 To 3
keyword = classify(i)
findUpper = 0
findLower = 0
'上から探す
For j = 1 To lastRow1 + lastRow2 - 4 Step 1
If Cells(j, 2) = keyword Then
findUpper = j
Exit For
End If
Next j
If findUpper > 0 Then
'下から探す
For j = lastRow1 + lastRow2 - 4 To 1 Step -1
If Cells(j, 2) = keyword Then
findLower = j
Exit For
End If
Next j
'コピー
Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy
Sheets(keyword).Select
Range("A2").Select
ActiveSheet.Paste
Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft
Sheets(tempSheet).Select
End If
Next i
'一時シートの削除
Application.DisplayAlerts = False
Temp.Delete
Application.DisplayAlerts = True
'アクティブセルをA1にしておく
For Each ws In Worksheets
Sheets(ws.Name).Select 'シート選択
Application.CutCopyMode = False
Range("A1").Select
Next ws
Bank1.Select
'画面更新を行う
Application.ScreenUpdating = True
MsgBox "実行しました"
End Sub
Sub MakeNewSheet_As_ThisName(ByVal GivenName As String)
'シートの有無を確認し、無ければ作る
Dim exist_flag As Boolean
Dim ws As Worksheet
exist_flag = False
For Each ws In Worksheets
If UCase(ws.Name) = UCase(GivenName) Then
'シートが存在する場合
exist_flag = True
Exit For
End If
Next ws
'シートを作成
If GivenName = "" Then
MsgBox "空白名のシートは作れません。"
ElseIf exist_flag = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = GivenName
End If
Sheets(GivenName).Select 'シート選択
End Sub
お礼
WorkSheetsがだめだったんですね。 うまくできました。 早々のご教授ありがとうございました。