エクセル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

回答No.4

snowsan062 · ベストアンサー

個人的には項目が増えても大丈夫な様に
最初から作ってないのが駄目なんじゃないかって気がするけど。
組み方も若干あれだし。

変えるなら以下の部分を変えればいいと思う。

変更前　'シートを作る
変更前　For i = 1 To 3
変更前　For j = 1 To 5
変更前　Cells(1, j) = title(j)
　↓
変更後　'シートを作る
変更後　For i = 1 To UBound(classify)
変更後　For j = 1 To 5
変更後　Cells(2, j) = title(j)

※UBoundは配列の最大値が返ってくるから
　今後項目が増えても変える必要が無くて済む。素直に9でも良い
※あとヘッダをここで２行目に貼る様に変える。

変更前　For i = 1 To 3
変更前　keyword = classify(i)
　↓
変更後　For i = 1 To UBound(classify)
変更後　keyword = classify(i)

※上と同じ。こっちも9でも良し

変更前　Range("A2").Select
変更前　ActiveSheet.Paste
変更前　Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft
　↓
変更前　Range("A3").Select
変更前　ActiveSheet.Paste
変更前　Range("B3:B" & 3 + (findLower - findUpper)).Delete Shift:=xlToLeft

※データを貼ってる所だからここを3行目に変える。

最後に以下の文だけど
＞又、全てのSheetで１行目には銀行名や項目名を入れたいので
何を入れるかが分からないのでアドバイスのしようがない。
銀行名や項目名が固定なのか、どこかのセルにあるものなのかとかさ。

回答No.3

imogasi

長いコードをコピペして、全体的に何をやっているかの詳細の説明も無く、丸投げで、読者や回答者にコードを読み解いて回答を呉れというのは、やりすぎと思う。
ある課題をＶＢＡで処理する場合も、色々な処理方法があり、個人の好みや実力を反映していて、読み解くのに時間がかかる場合が多いのだ。今回は新たな作り直しは対象外と思うが、質問のコードは余りベテランの感じが伝わってこない。
データ例も挙げてないので、判りにくい。
何かもっとすっきりしたやり方（処理手順・ロジック）もあるような気もする。
＞VBAについて全く無知のため
ＶＢＡの経験が無いものが、どうしてこういうことを、自分でやると言うことになるのか。
業者にでも頼むほか無いでしょう。
仕事で使うものなのに、内容が判らないものが触って、ある場合は結果がおかしくて、見過ごしていたなどがあったりしたらどうするのか。すみません、ですまない事態も考えられる。
篤志家（ＶＢＡが出来る社員が自発的にＶＢＡで便利にした）によるＶＢＡでの業務処理などは、良いように見えるが、引継ぎの際に、大きな問題を抱えることが宿命である。質問者の次もこの問題から逃れられない。
ーー
どうしてもやるなら、質問者への、提案・示唆の１つは、コードを印刷して、コードの各行の横にそのコード１行で何を（どういう処理を）して居るか、書き上げてみてはどうかな。一部の行にはコメントがあるが全行に入れてみる。
判らない行には印をして、質問するとか。
特にコード内で数字の定数になっている部分は、その数字が何の意味なのか考えて・調べて認識する。
そして、各行の処理の意味が判ったら、処理概要の塊と順序を箇条書き的に整理する。
質問者が処理内容を掴んでおく必要があると思うから。
（昔はフローチャートという、処理の図示を勧められたが）

回答No.2

keithin

誤記？：
＞エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから…

訂正：
エクセルでSheet1「と」Sheet2に各銀行の出納帳を作りそこから…

とりあえず今の状況だと，ピボットテーブルレポートでの整理もちょっとやりにくいです。（全く無理ではないですが）

ややイミフメイ：
＞全てのSheetで１行目には銀行名や項目名を入れたいので２行目から日付、内容・・・といったように入力したい

こういう事？
会費のシートの「１行目」，具体的に言えば「A1セル」に「銀行名１」，B1セルに「会費」と記入し，
２行目から銀行１シートからデータを転記する。２行目はタイトル行,３行目から実データ。
しばらく銀行１のデータがコピーできたら，改めて「銀行名２」「会費」とＡＢ列に記入し，
その下の行に続けて銀行２シートから転記する。タイトル行を１行記入し，実データが続く。
つまり今のマクロだと銀行１，２のデータが混在してしまうのが困っているので，分けて並べたい？

それともこういう事？
会費のシートの「１行目」は言い間違いで「Ａ列に」銀行名をだーーーっと列記し，「Ｂ列から」日付,内容・・・といったように入力したい

作成例：
sub macro1()
　dim Banks as variant
　dim LastRows() as variant
　dim Classify as variant
　dim i as long, j as long

’データ初期化（必要ならドンドン追記すればよい）
　banks = array("銀行１シート名","銀行２シート名")
　classify = array("会費","会議費","事務費","事業費","研修費","報償費","慶弔費","予備費","積立金")

　redim lastrows(ubound(banks))
　for i = 0 to ubound(banks)
　lastrows(i) = worksheets(banks(i)).range("A65536").end(xlup).row
　next i

’所定の「内容」ごとに繰り返す
　for i = 0 to ubound(classify)

’振り分け先シートの整備
　on error goto errhandle
　worksheets(classify(i)).select
　on error goto 0
　cells.clearcontents
　range("B1") = "内容"

’コピー
　for j=0 to ubound(banks)
　　worksheets(banks(j)).range("B2") = "内容"
　　range("A65536").end(xlup).offset(1) = banks(j)
　　range("A65536").end(xlup).offset(0, 1) = classify(i)
　　worksheets(banks(j)).range("A2:E" & lastrows(j)).advancedfilter _
　　　criteriarange:=range("B1:B2"), _
　　　action:=xlfiltercopy, _
　　　copytorange:=range("A65536").end(xlup).offset(1)
　next j

’掃除
　range("1:1").delete
　next i
exit sub

errhandle:
’シートがなければ新調する
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = classify(i)
　resume
end sub

＃補足
今のマクロで日付で並べ替えたりコピー後にＢ列を削除しているのは割愛している
ご説明では「項目」と称しているが，実物のエクセルでは「内容」が正しいとしている
説明が無いが，各銀行シートは２行目にラベル行（「日付」や「内容」etc），３行目から実データ(日付や数値）としている
今のマクロと同じ動作で，貼り付け先シートにデータが記入済みでも追記せず１行目からデータを貼り直している

＃実はホントはこうしたかったんです最初から作り直してくださいは無しでお願いします。
その場合は，今度はホントの条件を挙げてまた「新しいご相談で投稿し直して」くださいね。（とお願いしても聞く耳持たないヒトがすごく多いんで）

回答No.1

mitarashi

毎回全データを複写して処理しているので、データが増えてくると重そうですね。
For i = 1 To 3が二カ所ありますが、この3＝項目数ですので、それぞれ9に直せば動作すると思います。

ピボットテーブルで複数シートのデータを処理できるそうなので、それで十分な気もします。シート毎には分かれませんが、どうせ人間が複数シートの内容を同時に見るには、印刷せざるを得ないと思いますので。ご参考まで。
http://www.atmarkit.co.jp/fwin2k/win2ktips/407pivokushi/pivokushi.html