エクセル：ワークシートを自動で生成&ワークシート名を自動で割り振り

質問

こんにちは　はじめまして

エクセルのワークシートを自動で生成するやり方を教えていただけますでしょうか。

やりたいことは以下の通りです。

何件かお店がありまして、毎日の売り上げ報告がファックスで本部に送られてきます。
そのファックスを見ながら、本部ではエクセルに入力し合計と累計を出すようにしています。

今現在は雛形ワークシートを一つ作り、手動でワークシートを30,31日分をコピーし、ブックには「店舗A2006年3月度分.xls」というようなブック名で保存してあります。
うちの会社は10日締めなので、3月で言うと、20060311から20060410(←数字は西暦)までのワークシートを作ります。

ワークシートのイメージとしてはこんな感じです。↓

シート名：店舗A.xls
ワークシート名：「雛形」
----------------------------
当日の日付
商品A　単価　○個　小計
商品B　単価　○個　小計
　　　　・
　　　　・　
　　　　　　　　　当日の合計
----------------------------

そしてこれの「雛形」を、自動で一か月分ワークシートをコピーするようにしたいのです。（今は手動でやってます）
VBAの本を読んで、For～Next分を使うと、指定した枚数コピーできることはわかったのですが、ご承知の通り30日の月もあれば31日の月もありまして、これを計算で自動に判断するようにできないでしょうか？

欲を言えば、さらにそのワークシート名も自動で「A店舗20060311」というように日付ごとのワークシート名を入れられるようになると助かります。

もっと欲を言えば、各ワークシートの特定のセルに当日の日付を入れてるのですが(セル番地はどこでもいいです)、そこの日付も、ワークシート名と連動して自動で入れられると助かります。

長文になってしまいましたが、どなたか教えていただけると助かります。

よろしくお願いいたします。

回答No.3

kokorone · ベストアンサー

申し訳ありません。会社で、サンプルを作成して、帰宅時間になったので、あまり確認せずに、提示してしまいました。
今は、自宅で、再度確認し、修正版を提示いたします。

Dim tmp_dat5 As Date
Dim tmp_dat6 As Integer
Dim cnt As Integer
Dim max As Integer
Dim nen As Integer
Dim getu As Integer
Dim sname As String
Dim tmp_day As String
Dim tmp_getu As String
Dim shop As String
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
If getu = 12 Then
nen = nen + 1
getu = 1
Else
getu = getu + 1
End If
tmp_dat5 = DateValue(nen & "/" & getu & "/01")
tmp_dat5 = tmp_dat5 - 1
tmp_dat6 = Day(tmp_dat5)
shop = Sheets("Work").Range("A2").Value
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
tmp_getu = Right("0" & getu, 2)
For cnt = 11 To tmp_dat6
tmp_day = Right("0" & cnt, 2)
sname = shop & nen & tmp_getu & tmp_day
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Sheets("雛形")
ActiveSheet.Name = sname
Sheets(sname).Range("L1").Value = nen & "/" & tmp_getu & "/" & tmp_day
Next cnt
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
If getu = 12 Then
nen = nen + 1
getu = 1
Else
getu = getu + 1
End If
tmp_getu = Right("0" & getu, 2)
For cnt = 1 To 10
tmp_day = Right("0" & cnt, 2)
sname = shop & nen & tmp_getu & tmp_day
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Sheets("雛形")
ActiveSheet.Name = sname
Sheets(sname).Range("L1").Value = nen & "/" & tmp_getu & "/" & tmp_day
Next cnt

お礼

お忙しい中、お手数おかけしました。

返事遅くなりまして大変申し訳ありません。今戻ってまいりました。

そしてこの修正版はとってもばっちりです！
完璧です。

本当にありがとうございました。
さっそく4月10日から使用させていただきます。

重ね重ねまことにありがとうございます。
なるべく自力で解決いたしますが、今後またおてを煩わせる事がございましたら、よろしくお願い申し上げます。

回答No.5

nekotaru

＃１です。

こんな感じでいかがでしょう？
ＢＯＯＫがあるフォルダと同じ場所に店舗のＢＯＯＫを作成します、

Sub test()

Dim TheMonth As Integer
Dim TheYear As Integer
Dim days As Integer
Dim ws_name As String
Dim i As Integer
Dim strTenpo As String

TheYear = InputBox("年を数字で入力してください。")
TheMonth = InputBox("月を数字で入力してください。")
strTenpo = InputBox("店舗を入力してください。")

Application.ScreenUpdating = False

' その月の日数を求める
days = DateSerial(TheYear, TheMonth + 1, 10) - DateSerial(TheYear, TheMonth, 11)

'
'シートコピー
'
Dim j As Integer
Dim wb As Workbook

Set wb = Workbooks.Add
ThisWorkbook.Worksheets("雛形").Copy before:=wb.Worksheets(1)

j = 11
For i = 1 To days + 1
wb.Worksheets("雛形").Copy before:=wb.Sheets("雛形")
'シート名
With ActiveSheet
.Name = strTenpo & Format(DateSerial(TheYear, TheMonth, j), "yyyymmdd")
.Cells(1, 1) = Format(DateSerial(TheYear, TheMonth, j), "yyyy/mm/dd")
End With

j = j + 1
Next i

'
'不要なシートを削除
'
Dim ws As Worksheet

Application.DisplayAlerts = False
For Each ws In wb.Worksheets
If ws.Name = "雛形" Or _
InStr(ws.Name, "Sheet") > 0 Then
ws.Delete
End If
Next
Application.DisplayAlerts = True

'
'作成したBook保存
'
wb.SaveAs ThisWorkbook.Path & "\" & strTenpo & Format(DateSerial(TheYear, TheMonth, 1), "yyyymm")
wb.Close

Application.ScreenUpdating = True

End Sub

お礼

わざわざ再度作っていただきまして、全く恐縮でございます。

色々なやりかたがあるのですねぇ・・・

ばっちり動きました。
気持ち良いくらいにぼこぼこできました。

まことにありがとうございます。
自分には到底できそうにもないことですが、これを機にVBAの勉強を始めたいと思います。

回答No.4

imogasi

Sub test01()
Application.ScreenUpdating = False
m = 5
For i = 11 To Day(DateSerial(2006, m + 1, 1) - 1)
If i = 11 Then
bsn = "Sheet1"
Else
bsn = sn
End If
sn = "A店舗" & Format(DateSerial(2006, m, i), "yyyymmdd")
Workbooks("Book1").Activate
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Workbooks("Book2.xls").Sheets(bsn)
ActiveSheet.Name = sn
Next i
'----
For i = 1 To 10
bsn = sn
sn = "A店舗" & Format(DateSerial(2006, m + 1, i), "yyyymmdd")
Workbooks("Book1").Activate
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Workbooks("Book2.xls").Sheets(bsn)
ActiveSheet.Name = sn
Next i
Application.ScreenUpdating = True
End Sub
２００６年、５月次、A店舗の例です。月はINPUTBOXでとるとか、A店舗以外も含めForNextで繰り返すかINPUTBOXでとることを考え修正してください。
Book1に雛形、Book2を開いておいて実行のこと。Book2に望みのシートができます。

お礼

ありがとうございます。

皆様のおかげで、無事解決することができました。

わたしも、何らかの形で貢献できるようにがんばります。

お忙しい中お手を煩わせまして、大変ありがとうございました。

回答No.2

kokorone

Dim tmp_dat5 As Date
Dim tmp_dat6 As Integer
Dim cnt As Integer
Dim max As Integer
Dim nen As Integer
Dim getu As Integer
Dim sname As String
Dim tmp_day As String
Dim tmp_getu As String
Dim shop As String
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
If getu = 12 Then
nen = nen + 1
getu = 1
Else
getu = getu + 1
End If
tmp_dat5 = DateValue(nen & "/" & getu & "/01")
tmp_dat5 = tmp_dat5 - 1
tmp_dat6 = Day(tmp_dat5)
shop = Sheets("Work").Range("A2").Value
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
tmp_getu = Right("0" & getu, 2)
For cnt = 11 To tmp_dat6
tmp_day = Right("0" & cnt, 2)
sname = shop & nen & tmp_getu & tmp_day
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Sheets("雛形")
ActiveSheet.Name = sname
Sheets("雛形").Range("C5").Value = Sheets("Work").Range("A1").Value & "/" & Sheets("Work").Range("B1").Value & "/" & tmp_dat
Next cnt
nen = Sheets("Work").Range("A1").Value
getu = Sheets("Work").Range("B1").Value
If getu = 12 Then
nen = nen + 1
getu = 1
Else
getu = getu + 1
End If
tmp_getu = Right("0" & getu, 2)
For cnt = 1 To 10
tmp_day = Right("0" & cnt, 2)
sname = shop & nen & tmp_getu & tmp_day
Sheets("雛形").Select
Sheets("雛形").Copy Before:=Sheets("雛形")
ActiveSheet.Name = sname
Sheets("雛形").Range("C5").Value = Sheets("Work").Range("A1").Value & "/" & Sheets("Work").Range("B1").Value & "/" & tmp_dat
Next cnt

これでいかがでしょうか？
「Ｗｏｒｋ」シートのＡ１に年、Ｂ１に月、Ａ２に店舗名を
入れてくださいね。

お礼

すばやいご回答まことにありがとうございます。

しかし短時間でこんなに複雑なVBAを書いていただきまして本当に敬服いたします。

早速試させていただきました。

めちゃめちゃちゃんと動いてます！
本当にありがとうございます。

それと、もしお時間ございましたらご質問させていただきたいのですが、ワークシートを生成した後「C5」セルに日付が入る仕様になっていると思うのですが、それをわたしのほうで「L1」セルに書き込むように、上記のVBAの32行目と末尾から3行目の「C5」を「L1」に書き換えて実行しました。

そのせいなのか、日付の表示が全てのワークシートで「2006/02」となってしまいます。
「Work」ワークシートのA1には2006、A2には店舗名、B1には2、と入れてあります。（B1を2にしたのは、28日までしかないので、確認がしやすかった為です）
もし書き換えていけない部分を書き換えてしまったのでしたらご指摘いただけると幸いです。
（もしご迷惑でなければで結構です）

お忙しい中、お手を煩わせて大変ありがとうございました。

回答No.1

nekotaru

お疲れ様です。

えいや！で作ったのですが参考になりましたら幸いです。
雛形というシートを用意してご利用ください。
ファイルの保存については、また後ほどに、時間があればご協力させていただきます。
（別ＢＯＯＫの作成が手間なのでorz）

Sub test()
Dim TheMonth As Integer
Dim TheYear As Integer
Dim days As Integer
Dim tenpo As String
Dim ws_name As String
Dim Strdays As String
Dim i As Integer

TheYear = InputBox("年を数字で入力してください。")
TheMonth = InputBox("月を数字で入力してください。")

' その月の日数を求める
days = Day(DateSerial(TheYear, TheMonth + 1, 1) - 1)

For i = 1 To days
'シートコピー
Worksheets("雛形").Copy before:=Sheets("雛形")

'日数補完
If i < 10 Then
Strdays = i
Else
Strdays = "0" & i
End If
'シート名決定
ActiveSheet.Name = TheYear & TheMonth & Strdays

Next i

End Sub

お礼

お忙しい中、わざわざご回答くださいまして誠にありがとうございます。

年と月をボックスに入力できるのは、とても思いつかないアイデアでした！

大変参考になりました。重ねて御礼申し上げます。