マクロを動かすとき、毎回シート名を変更したい

質問

マクロを登録しているBOOKに毎月前月の名前のシートを作成し、システムからダウンロードしたデーターを張り付けます。
そのデーターをVlookup関数で検索し「実績」のシートに、値を張り付けしています。
範囲のシート名が「2月」、「3月」と毎月変更になるので、インプットボックス？で変更できるようなコードを教えてください。
検索してできた初心者のコードですので、もっとスマートなコードがありましたら教えてください。よろしくお願いいたします。
エクセル2010を使用しています。
以下コード
Sub 毎月集計()

Dim i As Byte
Dim 範囲 As Range
Dim myV As Variant

Sheets("実績").Select
Set 範囲 = Worksheets("2月").Range("B7:AZ20")←ここをインプットボックスで変更したい

For i = Application.InputBox("開始行を半角で入力してください。", Default:=123, Type:=1) To Application.InputBox( _
"最終行を半角で入力してください。", Default:=123, Type:=1)

myV = Application.VLookup(Range("B" & i).Value, 範囲, 2, False)
If IsError(myV) Then
Range("C" & i).Value = "0"
Else
Range("C" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 3, False)
If IsError(myV) Then
Range("D" & i).Value = "0"
Else
Range("D" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 4, False)
If IsError(myV) Then
Range("E" & i).Value = "0"
Else
Range("E" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 5, False)
If IsError(myV) Then
Range("F" & i).Value = "0"
Else
Range("F" & i).Value = myV
End If
’以下51列まで続く
　Next i

End Sub

回答No.8

kagakusuki

>最終行は、「合計」の上までです。

との事ですが、それだけでは幾つか不明な点が御座います。
　まず、「合計」と入力されているのは何列なのでしょうか？(A列？　B列？　それともまた別の列？)
　それに、

>開始行の次の「合計」までと指定

という具合に、「開始行の次の」と書かれておられるという事は、「合計」と入力されているセルが同じ列に複数個存在しているのでしょうか？(「合計」と入力されているセルが必ず1個だけと決まっている場合には、処理が若干簡単になります)

　後、実績シートで書き換える範囲の内の最初の行が何行目になるのかという事に関しては、自動化する事に役立つ様な何か決まりは御座いますか？
　例えば、特定の列が空欄になっている行から、「合計」と入力されている行までの範囲は必ず全て書き換えるといった決まりなどは無いでしょうか？(空欄が途中にある場合は、その下にデータが存在していても、そのデータは上書きの対象となる)
　後、各月のシートにおけるVLOOKUP関数で検索する範囲であるB7:AZ20に関してですが、このB7:AZ20という範囲は必ず固定なのでしょうか？
　もし最初の行である7行目や、最終行である20行目が固定値ではなく、変わる事もあるという場合には、それも自動で行範囲を求める様にできた方が宜しいのではないでしょうか？
　但し、自動化するためには、どの様な決まり事によって最初の行や最終行が決まるのかという情報が必要となります。
　例えば、B列においてB7セルよりも上の行に、検索値(実績シートのB列に入力されている値)と同じ値が入力されている可能性もあるのでしょうか？
　もし、B7セルよりも上の行に、検索値と同じ値が入力されている恐れが全くないという場合には、検索範囲をB7:AZ20ではなく、B:AZとしてしまった方が、月のシートでデータが入力されている行数が変わってしまった場合にも範囲の行番号を変えずに済みます。
　又、もしB7セルよりも上の行に、検索値と同じ値が入力されている恐れがあるという場合でも、B20セルよりも下の行に検索値と同じ値が入力されている恐れが全くないという場合には、B7セルから「B列にデータが入力されている最終行」までの範囲が自動的に検索範囲となる様にする方法も御座います。
　最初の行に関しましても、B列のいずれかの行に項目名等の特定の値が必ず入力されていて、その行よりも何行だけ下の行の所から検索範囲が始まっている、と言った決まり事は無いのでしょうか？
　ですから、もしB7:AZ20が固定ではなく、行範囲が変化するのに合わせて検索範囲を自動的に変更した方が良いという場合には、検索範囲の最初の行と、最終行が、それぞれどのような決まり事によって決まるのかという事を御教え願います。

>難しくて、なかなか理解ができていないのが現状です。

　元データとして指定するシート名の入力や、実績シートで書き換える行範囲の指定は、マクロを実行した時に現れるダイアログボックスの指示に従えば良い様になっておりますし、月のシートにおける検索範囲であるB7:AZ20に関しましても、

'処理に関わるセル範囲を設定
RangeF = "B7" '元データが入力されているセル範囲の左上の隅のセル
RangeL = "AZ20" '元データが入力されているセル範囲の右下の隅のセル

という部分で記述されている"B7"や"AZ20"を実際に必要となる検索範囲に合わせて変更すれば良い様になっております。
　他には何か解らない処は御座いますでしょうか？

お礼

kagakusukiさん、ありがとうございました。
思うように動かすことができました。

もっと便利にできるように勉強したいと思います。
これからもよろしくお願いいたします。

補足

お世話になります。
いつも、説明不足で申し訳ありません。

>まず、「合計」と入力されているのは何列なのでしょうか？
　　B列です。

>「合計」と入力されているセルが同じ列に複数個存在しているのでしょうか？
　　1年分同じシートに入力していきますので、１２個あります。

>実績シートで書き換える範囲の内の最初の行が何行目になるのか
　　最初の4行にマクロのボタンを設置し、ウィンドウ枠の固定をしました。
　　5行目、B5に「第1四半期集計（2015/4/1～2015/6/30）4月」というタイトル
　　B6に項目名、B7から都道府県名、C7から実績データー　最後に合計をSUMで入れます。
　　合計の下1行空白で、次の行からタイトルがあって、その下に項目、都道府県名・・・と同じ表が12個。

>各月のシートにおけるVLOOKUP関数で検索する範囲であるB7:AZ20は固定・・
　　言われてみると、B７は固定ですが、AZは、30ぐらいまである場合もでてきます。

>B列においてB7セルよりも上の行に、検索値(実績シートのB列に入力されている値)と同じ値
　　B1に入っています。がそれ以外はないです。

>検索範囲の最初の行と、最終行が、それぞれどのような決まり事
　　最初の行は、B列に「地域名称」という項目があります。その下からです。
　　最終行は、右も下も空欄です。B列に「合計：」と入っています。

>他には何か解らない処は御座いますでしょうか？
　　自分で勉強しないといけないことです。
　　 kakunin = 0 と　　Cells(i, j + 1).Value = "0"
　　””で０を囲むのは、Cellsだからなのでしょうか？
　　新しい作表の時に、ちょっとネットを検索して、セルの位置を変えたりするぐらいで
　　理解していないからだと思います。
　　全部教えてもらって、すみません。

回答No.7

kagakusuki

>最後の点については、私の力不足で、空白のセルは空白のままの値を持ってくるようになっていますが、できれば、「０」を入力したいです。

　それではちょっと正道から外れてしまうかも知れませんが、実績シートにおいて書き換える範囲に対し、一旦、マクロによってWorksheet関数を自動的に入力した後、得られた値のみを同じ範囲にコピーする事で、Worksheet関数を消去して値のみを残すという方法は如何でしょうか？
　但し、この方法は単なるセル範囲からのデータのコピーではなく、書き換えるセル範囲に含まれているセル毎に計算処理が必要となりますので、書き換えるセル範囲に含まれているセルの個数があまりにも多くなる場合には処理の際の負荷が大きくなるため、処理速度の高速化を図る事にはあまり向いた方法とは申せません。
　とは言え、御質問文中に質問者様が記しておられるVBAもまたセル毎に1つずつ計算する方式ですので、質問者様の方法と比べて特に処理が遅くなるという訳ではないと思います。

　まず、前回提示させて頂いたVBAの中の

Dim sname As String 'コピー元のシート名

という箇所を、次の様に変更して下さい。

Dim sname, RangeF, RangeL, RangeR1C1 As String
　'sname:コピー元のシート名
　'RangeF:コピー元の範囲の左上の隅のセルのセル番号をA1形式で示した文字列
　'RangeL:コピー元の範囲の右下の隅のセルのセル番号をA1形式で示した文字列
　'RangeR1C1:コピー元の範囲をR1C1形式で示した文字列

　　次に、「'処理に関わるセル範囲を設定」以下の部分を次の様に変更して下さい。

'処理に関わるセル範囲を設定
RangeF = "B7" '元データが入力されているセル範囲の左上の隅のセル
RangeL = "AZ20" '元データが入力されているセル範囲の右下の隅のセル
RangeR1C1 = "'" & sname & "'!R" & Range(RangeF).Row & "C" _
& Range(RangeF).Column & ":R" & Range(RangeL).Row & "C" _
& Range(RangeL).Column '元データが入力されているセル範囲の設定
mycs = Range(RangeF & ":" & RangeL).Columns.Count - 1

'選択したシートのデータの一部を、実績シートへコピー
With Sheets("実績")
.Range("C" & fr).Resize(lr - fr + 1, mycs).FormulaR1C1 = _
"=IF(ISERROR(1/(VLOOKUP(RC2," & RangeR1C1 _
& ",COLUMNS(C2:C),FALSE)<>"""")),0,VLOOKUP(RC2," & RangeR1C1 _
& ",COLUMNS(C2:C),FALSE))"
.Range("C" & fr).Resize(lr - fr + 1, mycs).Value = _
.Range("C" & fr).Resize(lr - fr + 1, mycs).Value
End With

End Sub

　これで各月のシートで空欄となっている箇所を参照した場合には、0が入力される事になります。
　尚、今回のVBAではRange変数「範囲」を使用しませんので、Dimで変数を定義している箇所から「範囲」を削除してしまっても構いません。

　後、話は変わりますが、回答No.4の所でお尋ねした

>それともう一点確認したい事があるのですが、

>Application.InputBox( _
>"最終行を半角で入力してください。", Default:=123, Type:=1)

>の所で設定する「最終行」とは
>(中略)
>もし前者である場合には、最終行の行番号の取得もマクロによって自動的に行う様にする方法もあるかと思いますので、宜しければ最終行や開始行の決め方も御教え願います。

の件に関して未だお返事を頂いておりませんが、最終行の行番号の取得は自動化はしなくても良い事だと考えても宜しいのでしょうか？

補足

kagakusukiさん、ありがとうございます。
希望どおりに動きました。ただ、難しくて、なかなか理解ができていないのが現状です。

そして、ご質問にもお答えせず、申し訳ございません。
最終行は、「合計」の上までです。
開始行の次の「合計」までと指定できたら、入力が減ってうれしいです。
引き続きよろしくお願いします。

回答No.6

kagakusuki

>Range("□" & i).Value = "0"は
>実績シートにはあって、範囲にない場合、０を入力したいです。

　「実績シートにはあって、範囲にない」とは、検索値の事だと考えれば宜しいのでしょうか？
　つまり、

・実績シートのB列に入力されている値と同じ値が入力されているセルが、範囲の左端には存在しなかった場合には、実績シートにおいてその値がB列に入力されている行の他の列のセルには全て0を入力する

・「範囲においてセルの所に入っている値が0である」という場合には、実績シートにおける該当するセルの所にも0を入力する

・「『実績シートのB列』と『範囲の左端の列』の双方に同じ値はあるものの、『範囲においてその値がある行』の中に、値が入力されていない空欄のセルがある」という様な場合には、範囲における該当するセルに合わせて空欄とする

と考えれば宜しいのでしょうか？(少なくとも質問者様が作られたマクロではそうなっています)
　もしそれで宜しければ、回答No.5で提示させて頂いたVBAにおいて

>'処理に関わるセル範囲を設定

という箇所の7行下の所にある

.Range("C" & fr).Resize(lr - fr + 1, mycs).Delete

という行を

.Range("C" & fr).Resize(lr - fr + 1, mycs).Value = "0"

に変更して下さい。
　そうする事で、まず実績シートにおいて「書き換えの対象となるセル範囲」に含まれているすべてのセルの値を、一旦、0に書き換えます。
　その上で、「'選択したシートのデータの一部を、実績シートへコピー」の所の処理によって"範囲"の値がコピーされる段階で、「空欄となっているというデータ」も0の上から上書きされます。

>C7～AZ27まで、色も罫線も消えてしまいました。

　申し訳御座いません。私がVBAを作り直す上で、実績シート上の古いデータを消去する際にDeleteメソッドを使用して行う様にしてしまっていた事が原因です。
　ですから、

.Range("C" & fr).Resize(lr - fr + 1, mycs).Value = "0"

に変更して頂ければ、その様な現象は無くなります。

補足

kagakusukiさん、ありがとうございました。

>「実績シートにはあって、範囲にない」とは、検索値の事

3点あげていただきましたが、上の2点はそのとおりです。
最後の点については、私の力不足で、空白のセルは空白のままの値を持ってくるようになっていますが、
できれば、「０」を入力したいです。
どこを訂正すれば、「０」が入るようになるのでしょうか？
ネット上にあったコードをいろいろつなぎ合わせて、セルの場所だけを変更したものです。よろしくお願いします。

回答No.5

kagakusuki

回答No.4の続きです。

　回答No.4の末尾にある

GoTo label2
Case vbCancel
GoTo label1
End Select

の後ろに、以下の構文を続けて追加して下さい。

'最終行の指定　及び　指定された行範囲の確認
lr = fr
label3:
kakunin = 0
lr = Application.InputBox(Title:="最終行の指定", Prompt:="最終行を半角で入力してください。" _
& Chr(13) & Chr(13) & "　※0を入力するか、[キャンセル]ボタンをクリックすると、" _
& Chr(13) & "　「開始行の指定」操作に戻ります。", Default:=lr, Type:=1)
If lr <> Int(lr) Or lr <= fr Or lr > Rows.Count Then
kakunin = MsgBox("無効な値が入力されました。" & Chr(13) & "最終行の行番号には" & Chr(13) _
& "　" & fr & "(開始行)～" & Rows.Count & Chr(13) & "　　　の範囲内の整数値を入力して下さい。" _
& Chr(13) & Chr(13) & "　　[OK]:「最終行の指定」の操作をやり直します" & Chr(13) _
& "　　[キャンセル]:「開始行の指定」の操作に戻ります" _
, vbOKCancel + vbExclamation, "無効な行番号")
End If
Select Case kakunin
Case vbOK
GoTo label3
Case vbCancel
GoTo label2
End Select

kakunin = 0
kakunin = MsgBox("入力された行範囲は" & Chr(13) & "　　" & fr & "行目～" & lr & "行目です。" _
& Chr(13) & Chr(13) & "宜しいですか？" & Chr(13) & Chr(13) _
& "　[はい]:処理を続行します" & Chr(13) _
& "　[いいえ]:「開始行の指定の指定」の操作からやり直します" & Chr(13) _
& "　[キャンセル]:処理を中止してマクロを終了します。" _
, vbYesNoCancel + vbQuestion + vbDefaultButton2, "入力値確認")
Select Case kakunin
Case vbNo
GoTo label2
Case vbCancel
Exit Sub
End Select

'処理に関わるセル範囲を設定
Set 範囲 = Sheets(sname).Range("B7:AZ20") '元データが入力されているセル範囲の設定
With Sheets("実績")
.Range("C1").Value = sname
mycs = 範囲.Columns.Count - 1
Set searchC = 範囲.Resize(範囲.Rows.Count, 1)
Set copyR = 範囲.Resize(1, mycs).Offset(0, 1)
.Range("C" & fr).Resize(lr - fr + 1, mycs).Delete
Set SearchV = .Range("B" & fr & ":B" & lr)

'選択したシートのデータの一部を、実績シートへコピー
For Each c In SearchV
If c.Value <> "" And _
Application.WorksheetFunction.CountIf(searchC, c.Value) > 0 Then
myr = Application.WorksheetFunction.Match(c.Value, searchC, 0)
c.Resize(1, mycs).Offset(0, 1).Value = copyR.Offset(myr - 1).Value
End If
Next c
End With

End Sub

　以上です。

補足

kagakusukiさん、とっても丁寧な解説、ありがとうございます。
Range("□" & i).Value = "0"は
実績シートにはあって、範囲にない場合、０を入力したいです。
システムからダウンロードするデーターは、実績のあった都道府県のみダウンロードできます。
なので、実績には、約２０の都道府県名が入力されています。
また、1年分の4月～3月までを実績シートで管理してあります。
B列に１２の同じ都道府県名があるので、2月は、「7行目から27行目まで」のように
最初と最後を指定するように考えました。
うまく動いたのですが、C7～AZ27まで、色も罫線も消えてしまいました。
どうしたらいいのでしょうか？
お忙しい中、申し訳ありません。よろしくお願いいたします。

回答No.4

kagakusuki

>スマートなコードについては、51列まで列ごとにコードを書いているので

の件に関して確認したい事が御座います。

Range("□" & i).Value = "0"

という箇所で貼り付ける値を「"0"」という文字列とされていますが、これは必要な処置なのでしょうか？
　単なる空欄にしてしまってはいけないのでしょうか？
　もし、空欄としてしまっても良いのでしたら、態々、セルを1個ずつ処理せずとも、コピー元である指定した月のシートにおいて、B列に該当する検索値が入っている行を1度に丸ごと貼り付ける様な処理をしてしまえば良いと思います。

　それともう一点確認したい事があるのですが、

Application.InputBox( _
"最終行を半角で入力してください。", Default:=123, Type:=1)

の所で設定する「最終行」とは、「『実績』シートのB列において、データが入力されている最終行」によって決まるのでしょうか？
　それとも、「『実績』シートのB列において、入力されているデータの内容」の内、書き換えの対象とするものと、対象としないものを、人間が任意に取捨選択する事によって決まるものであって、「データがどの行まで入力されているのか」という事には特に関係してはいないのでしょうか？
　もし前者である場合には、最終行の行番号の取得もマクロによって自動的に行う様にする方法もあるかと思いますので、宜しければ最終行や開始行の決め方も御教え願います。

　尚、以下は検索値が存在しない行のセルを「"0"」ではなく、空欄にする場合のVBAの改良案です。
　繰り返し処理の部分には、For～Nextではなく、For Each～Nextを使用する事で、検索値が入力されているセルの指定を若干簡略化した上で、Resizeプロパティ及びOffsetプロパティと組み合わせる事で、貼り付け先のセル範囲を横1行丸ごと一気に指定する様にしております。
　コピー元のセル範囲もMach関数で「『検索値が入力されているセル』が存在する行の位置」を取得してから、Resizeプロパティを利用して、コピーしなければならないセル範囲を横1行丸ごと一気に指定する様にしております。
　その上で、

貼り付け先のセル範囲.Value = コピー元のセル範囲.Value

という形式の構文によって、1行分のデータを丸ごとコピーする様にしています。

　尚、下記のVBAの構文はかなり長いものになっておりますが、それはInputBoxやMsgBox等の、「コピー元のシート名」、「開始行」、「最終行」を手入力する際に必要となる処理や、誤ったデータを入力してしまった場合に処理に関わる部分の記述が長くなってしまったからであり、月のシートからデータをコピーするための処理をしている所は「'処理に関わるセル範囲を設」よりも後の所で記述されている部分に過ぎません。

Sub 毎月集計改3()

Dim fr, lr, myr As Long 'fr:開始行、lr:最終行、myr:書き換える行
'255までしか入力できないByte型では、1048576行あるExcel2007以降のバージョンにおいては、
'全ての行に対応する事は出来ないため、Longe型にする必要があります。
Dim kakunin, mycs As Integer
'kakunin:MsgBoxの戻り値を格納するための変数、mycs:書き換えるセル範囲の列幅
Dim 範囲, c, searchC, SearchV, copyR, pasteR As Range
'範囲:元データとして参照するセル範囲
'c:繰り返し処理用、
'searchC:変数「範囲」で指定されたセル範囲の中の左端の列のセル範囲
'SearchV:検索値となるデータが入力されている縦一列のセル範囲
'copyR:変数「範囲」で指定されたセル範囲の中で、上端の行のセル範囲から、左端のセルを除いたセル範囲
'pasteR:書き換えるセル範囲
'Dim myV As Variant 'データの一時格納用の変数(使用せず)
Dim sname As String 'コピー元のシート名

'元データとして参照するシートの指定
label1:
sname = Application.InputBox(Title:="シート名の指定", Prompt:="月を" & Chr(13) _
& "　　1～12　の数値か" & Chr(13) & "　　1月～12月　の文字列" _
& Chr(13) & "で入力して下さい", Type:=2)
kakunin = 0
If sname = "" Or sname = False & "" Then
kakunin = MsgBox("シート名が入力されていません。" & Chr(13) _
& "処理を中止してマクロを終了しますか?" & Chr(13) & Chr(13) _
& "　[再試行]:「シート名の指定」の操作に戻ります" & Chr(13) _
& "　[キャンセル]:処理を中止してマクロを終了します" _
, vbRetryCancel + vbExclamation + vbDefaultButton2, "処理の中止")
End If
Select Case kakunin
Case vbRetry
GoTo label1
Case vbCancel
Exit Sub
End Select
If IsError(Evaluate("ROW('" & sname & "'!A1)")) And IsDate(sname & "月1日") Then sname = sname & "月"
kakunin = 0
kakunin = MsgBox("入力されたシート名は" & Chr(13) & Chr(13) & "　　" & sname & Chr(13) _
& Chr(13) & "です。" & Chr(13) & "宜しいですか？", vbOKCancel + vbQuestion, "入力値確認")
If kakunin = vbCancel Then GoTo label1
If IsError(Evaluate("ROW('" & sname & "'!A1)")) Then
kakunin = MsgBox("入力された名称のシートは存在しません。" & Chr(13) _
& "シート名を入力しなおしますか?" & Chr(13) _
& "　[はい]:「シート名の指定」の操作に戻ります" & Chr(13) _
& "　[いいえ]:処理を中止します" _
, vbYesNo + vbExclamation + vbDefaultButton1, "無効なシート名")
End If
Select Case kakunin
Case vbYes
GoTo label1
Case vbNo
kakunin = MsgBox("処理を中止してマクロを終了します。" & Chr(13) & Chr(13) _
& "入力された名称のシートは存在しませんでしたので、" & Chr(13) _
& "その名称のシートが必要であれば、新たなシートを作成して下さい。" _
, vbOKOnly + vbInformation, "マクロの終了")
Exit Sub
End Select

'開始行を指定
fr = 123
label2:
kakunin = 0
fr = Application.InputBox(Title:="開始行の指定", Prompt:="開始行を半角で入力してください。" _
& Chr(13) & Chr(13) & "　※0を入力するか、[キャンセル]ボタンをクリックすると、" _
& Chr(13) & "　「シート名の指定」操作に戻ります。", Default:=fr, Type:=1)
If fr <> Int(Abs(fr)) Or fr = 0 Or fr > Rows.Count Then
kakunin = MsgBox("無効な値が入力されました。" & Chr(13) & "開始行の行番号には" & Chr(13) _
& "　1～" & Rows.Count & Chr(13) & "　　　の範囲内の整数値を入力して下さい。" & Chr(13) & Chr(13) _
& "　　[OK]:「開始行の指定」の操作をやり直します" & Chr(13) _
& "　　[キャンセル]:「シート名の指定」の操作に戻ります" _
, vbOKCancel + vbExclamation, "無効な行番号")
End If
Select Case kakunin
Case vbOK
GoTo label2
Case vbCancel
GoTo label1
End Select

'※まだ途中なのですが、そろそろこのサイトの回答欄に入力可能な文字数の限度を超えそうですので、残りは又後で投稿致します。

回答No.3

kagakusuki

>”2”と入れると、2月ですね、と聞いてきて、OKを押すと、シートは存在しません、と帰ってきます。
>”２月”と入力すると、型が違いますというエラーが出て動きません。

　申し訳御座いません、こちらのミスです。
　やはり時間が無い事を気にしながら作ったものを、十分な確認もせずに回答として投稿した事がそもそもの間違いでした。

　以下に訂正版を掲載致しました。
　一応、今回は

>範囲のシート名が「2月」、「3月」と毎月変更になるので、インプットボックス？で変更

という箇所に関しては、一通り確認したつもりなのですが、如何でしょうか。
　尚、シート名の指定をインプットボックスで変更する様にしただけで、

>もっとスマートなコードがありましたら教えてください。

という点に関しましては未だ手を付けておらず、今のところは質問者様のVBAをそのまま使っているだけです。
(未確認というだけの話であって、「改良の余地が無い」のかどうかはまだ判りません)

Sub 毎月集計改2()

Dim i As Byte
Dim 範囲 As Range
Dim myV As Variant

'↓ここからが変更箇所

Dim kakunin As Integer
Dim mname As String

label1:
mname = Application.InputBox(Title:="シート名の指定", Prompt:="月を" & Chr(13) _
& "　　1～12　の数値か" & Chr(13) & "　　1月～12月　の文字列" _
& Chr(13) & "で入力して下さい", Type:=2)
kakunin = 0
If mname = "" Or mname = False & "" Then
kakunin = MsgBox("シート名が入力されていません。" & Chr(13) _
& "処理を中止してマクロを終了しますか?" & Chr(13) & Chr(13) _
& "　[再試行]:月の指定の操作に戻ります" & Chr(13) _
& "　[キャンセル]:処理を中止してマクロを終了します" _
, vbRetryCancel + vbExclamation + vbDefaultButton2, "処理の中止")
End If
Select Case kakunin
Case vbRetry
GoTo label1
Case vbCancel
Exit Sub
End Select
If IsError(Evaluate("ROW('" & mname & "'!A1)")) And IsDate(mname & "月1日") Then mname = mname & "月"
kakunin = 0
kakunin = MsgBox("入力されたシート名は" & Chr(13) & Chr(13) & "　　" & mname & Chr(13) _
& Chr(13) & "です。" & Chr(13) & "宜しいですか？", vbOKCancel + vbInformation, "入力値確認")
If kakunin = vbCancel Then GoTo label1
If IsError(Evaluate("ROW('" & mname & "'!A1)")) Then
kakunin = MsgBox("入力された名称のシートは存在しません。" & Chr(13) _
& "シート名を入力しなおしますか?" & Chr(13) _
& "　[はい]:月の指定の操作に戻ります" & Chr(13) _
& "　[いいえ]:処理を中止します" _
, vbYesNo + vbExclamation + vbDefaultButton1, "無効なシート名")
End If
Select Case kakunin
Case vbYes
GoTo label1
Case vbNo
kakunin = MsgBox("処理を中止してマクロを終了します。" & Chr(13) & Chr(13) _
& "入力された名称のシートは存在しませんでしたので、" & Chr(13) _
& "その名称のシートが必要であれば、新たなシートを作成して下さい。" _
, vbOKOnly + vbInformation, "マクロの終了")
Exit Sub
End Select
Sheets("実績").Select
Set 範囲 = Worksheets(mname).Range("B7:AZ20") '←ここをインプットボックスで変更したい

'↑ここまでが変更箇所

For i = Application.InputBox("開始行を半角で入力してください。", Default:=123, Type:=1) To Application.InputBox( _
"最終行を半角で入力してください。", Default:=123, Type:=1)
myV = Application.VLookup(Range("B" & i).Value, 範囲, 2, False)
If IsError(myV) Then
Range("C" & i).Value = "0"
Else
Range("C" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 3, False)
If IsError(myV) Then
Range("D" & i).Value = "0"
Else
Range("D" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 4, False)
If IsError(myV) Then
Range("E" & i).Value = "0"
Else
Range("E" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 5, False)
If IsError(myV) Then
Range("F" & i).Value = "0"
Else
Range("F" & i).Value = myV
End If
'以下51列まで続く
Next i

End Sub

お礼

kagakusukiさん、お忙しい中、ありがとうございました。
完璧です！
Dimの型が違うのかな、IsDateが日付じゃないからかな、などと考えておりましたが
全く違いましたね。
私にはレベルが高すぎて、理解ができておりませんがこれから勉強したいとおもいます。
スマートなコードについては、51列まで列ごとにコードを書いているので
LoopかForでなんとかならないものかと思っています。
こちらは、別に質問を立てたいと思いますので、引き続きよろしくお願いいたします。
本当にありがとうございました。

回答No.2

kagakusuki

回答No.1です。
　失礼しました。先程の回答では、ちょっとコピー&ペーストする範囲を間違えておりました。
　正しくは以下の通りです。

Sub 毎月集計()

Dim i As Byte
Dim 範囲 As Range
Dim myV As Variant

'↓ここからが変更箇所

Dim kakunin As Integer
Dim mname　As String

label1:
mname = Application.InputBox(Title:="月の指定", Prompt:="月を" & Chr(13) _
& "　　1～12　の数値か" & Chr(13) & "　　1月～12月　の文字列" _
& Chr(13) & "で入力して下さい", Type:=2)
If mname = "" Or mname = False Then
kakunin = MsgBox("シート名が入力されていません。" & Chr(13) _
& "処理を中止してマクロを終了しますか?" _
, vbRetryCancel + vbExclamation + vbDefaultButton2, "処理の中止")
Select Case kakunin
Case vbRetry
GoTo label1
Case vbCancel
Exit Sub
End Select
kakunin = -1
ElseIf _
IsError(Evaluate("ROW(INDIRECT(""'Sheet"" & mname & ""'!A1""))")) And _
IsDate(mname & "月1日") Then mname = mname & "月"
End If
kakunin = MsgBox("入力された月名は" & Chr(13) & mname & Chr(13) & "です。" & Chr(13) _
& "宜しいですか？", vbOKCancel + vbInformation, "入力値確認")
If kakunin = vbCancel Then GoTo label1
If IsError(Evaluate("ROW(INDIRECT(""'Sheet"" & mname & ""'!A1""))")) Then
kakunin = MsgBox("入力された名称のシートは存在しません。" & Chr(13) _
& "シート名を入力しなおしますか?" & Chr(13) _
& "　[はい]:月の指定の操作に戻ります" & Chr(13) _
& "　[いいえ]:処理を中止します" _
, vbYesNo + vbExclamation + vbDefaultButton1, "無効なシート名")
End If
Select Case kakunin
Case vbYes
GoTo label1
Case vbNo
kakunin = MsgBox("処理を中止してマクロを終了します。" & Chr(13) & Chr(13) _
& "入力された名称のシートは存在しませんでしたので、" & Chr(13) _
& "その名称のシートが必要であれば、新たなシートを作成して下さい。" _
, vbOKOnly + vbInformation, "マクロの終了")
Exit Sub
End Select

Sheets("実績").Select
Set 範囲 = Worksheets(mname).Range("B7:AZ20")'←ここをインプットボックスで変更したい

'↑ここまでが変更箇所

For i = Application.InputBox("開始行を半角で入力してください。", Default:=123, Type:=1) To Application.InputBox( _
"最終行を半角で入力してください。", Default:=123, Type:=1)

myV = Application.VLookup(Range("B" & i).Value, 範囲, 2, False)
If IsError(myV) Then
Range("C" & i).Value = "0"
Else
Range("C" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 3, False)
If IsError(myV) Then
Range("D" & i).Value = "0"
Else
Range("D" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 4, False)
If IsError(myV) Then
Range("E" & i).Value = "0"
Else
Range("E" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 5, False)
If IsError(myV) Then
Range("F" & i).Value = "0"
Else
Range("F" & i).Value = myV
End If
’以下51列まで続く
　Next i

End Sub

補足

kagakusukiさん、コードをありがとうございます。
なかなか難しいですね。
さて、”2”と入れると、2月ですね、と聞いてきて、OKを押すと、シートは存在しません、
と帰ってきます。
”２月”と入力すると、型が違いますというエラーが出て動きません。
どこを編集すればいいのでしょうか？
よろしくお願いします。

回答No.1

kagakusuki

ちょっと時間が無くて動作を十分には確認できていないのですが、次の様にされては如何でしょうか？

Sub 毎月集計()

Dim i As Byte
Dim 範囲 As Range
Dim myV As Variant

'↓ここからが変更箇所

Dim kakunin As Integer
Dim mname　As String

label1:
mname = Application.InputBox(Title:="月の指定", Prompt:="月を" & Chr(13) _
& "　　1～12　の数値か" & Chr(13) & "　　1月～12月　の文字列" _
& Chr(13) & "で入力して下さい", Type:=2)
If mname = "" Or mname = False Then
kakunin = MsgBox("シート名が入力されていません。" & Chr(13) _
& "処理を中止してマクロを終了しますか?" _
, vbRetryCancel + vbExclamation + vbDefaultButton2, "処理の中止")
Select Case kakunin
Case vbRetry
GoTo label1
Case vbCancel
Exit Sub
End Select
kakunin = -1
ElseIf _
IsError(Evaluate("ROW(INDIRECT(""'Sheet"" & mname & ""'!A1""))")) And _
IsDate(mname & "月1日") Then mname = mname & "月"
End If
kakunin = MsgBox("入力された月名は" & Chr(13) & mname & Chr(13) & "です。" & Chr(13) _
& "宜しいですか？", vbOKCancel + vbInformation, "入力値確認")
If kakunin = vbCancel Then GoTo label1
If IsError(Evaluate("ROW(INDIRECT(""'Sheet"" & mname & ""'!A1""))")) Then
kakunin = MsgBox("入力された名称のシートは存在しません。" & Chr(13) _
& "シート名を入力しなおしますか?" & Chr(13) _
& "　[はい]:月の指定の操作に戻ります" & Chr(13) _
& "　[いいえ]:処理を中止します" _
, vbYesNo + vbExclamation + vbDefaultButton1, "無効なシート名")
End If
Select Case kakunin
Case vbYes
GoTo label1
Case vbNo
kakunin = MsgBox("処理を中止してマクロを終了します。" & Chr(13) & Chr(13) _
& "入力された名称のシートは存在しませんでしたので、" & Chr(13) _
& "その名称のシートが必要であれば、新たなシートを作成して下さい。" _
, vbOKOnly + vbInformation, "マクロの終了")
Exit Sub
End Select

'↑ここまでが変更箇所

Sheets("実績").Select
Set 範囲 = Worksheets("2月").Range("B7:AZ20")'←ここをインプットボックスで変更したい

For i = Application.InputBox("開始行を半角で入力してください。", Default:=123, Type:=1) To Application.InputBox( _
"最終行を半角で入力してください。", Default:=123, Type:=1)

myV = Application.VLookup(Range("B" & i).Value, 範囲, 2, False)
If IsError(myV) Then
Range("C" & i).Value = "0"
Else
Range("C" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 3, False)
If IsError(myV) Then
Range("D" & i).Value = "0"
Else
Range("D" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 4, False)
If IsError(myV) Then
Range("E" & i).Value = "0"
Else
Range("E" & i).Value = myV
End If
myV = Application.VLookup(Range("B" & i).Value, 範囲, 5, False)
If IsError(myV) Then
Range("F" & i).Value = "0"
Else
Range("F" & i).Value = myV
End If
’以下51列まで続く
　Next i

End Sub