マクロで、新しいシートを作りたい。

質問

エクセルのマクロを教えてください。

今は、Sheet1のA2に年月日、B2:H2にコード、項目１、項目２、・・・と入力します。
入力が終わったら、マクロを実行し、その後A2:H2をクリアしています。

今回やりたいのは、マクロの実行時に新しいシートを追加し、A2:H2をコピーしたいのです。

1 Sheet1のA2から、年月を取り出す。2003/1/1→200301
2 シートの中に、Sheet200301が有るかどうか調べ、無かったらSheet200301というシートを作る。
3 新しいシートを作ったら、Sheet4のA1:Z2をSheet200301に貼り付ける。
4 Sheet200301の最後の空白行を調べる。(新しいシートを作って最初は2行目になってもらいたい)
5 4で調べた空白行を次の行に貼り付ける。
6 4で調べた空白行にSheet1のA2:H2を貼り付ける。
7 Sheet1のA2:H2をクリアします。

よろしくお願いします。

回答No.4

nishi6 · ベストアンサー

＞5 4で調べた空白行を次の行に貼り付ける。
4、5、6あたりの書き方に疑問が残ります。特に5はよく理解できません。
どんどん次の行に貼り付ける意味？　シートを追加した時は3行目から貼り付け？

下は、どんどん次の行に貼り付け、シートを追加した時は3行目から貼り付けます。
１行あけたりしたければ、変更は容易でしょう。

Sheet1のコードウインドウに貼り付けます。
↓
Sub DataCopy()
　　Dim ws1 As Worksheet 'Sheet1
　　Dim sht As Worksheet 'シート
　　Dim shtChk As Boolean '追加すべきシートの有無
　　Dim AddShtName As String '追加すべきシート名
　　Set ws1 = Worksheets("Sheet1")

　　'***** 日付入力のチェック
　　If IsDate(Range("A2")) Then
　　　　AddShtName = "Sheet" & Format(Range("A2"), "yyyymm")
　　Else
　　　　MsgBox "日付入力が誤りです"
　　　　Exit Sub
　　End If

　　Application.ScreenUpdating = False

　　'***** 同一シート名の有無を調べる
　　For Each sht In Worksheets
　　　　If sht.Name = AddShtName Then
　　　　　　shtChk = True
　　　　End If
　　Next

　　'***** シートの追加
　　If shtChk = False Then
　　　　'同一シートがなければ追加する
　　　　Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
　　　　ActiveSheet.Name = AddShtName
　　　　'Sheet4をコピー
　　　　Worksheets("Sheet4").Range("A1:Z2").Copy Destination:=Worksheets(AddShtName).Range("A1")
　　Else
　　　　Worksheets(AddShtName).Activate
　　End If

　　'***** 最終入力行を調べて貼り付け
　　Dim EndRow As Long '最終入力行の次の行
　　EndRow = Worksheets(AddShtName).Range("A65536").End(xlUp).Row + 1
　　ws1.Range("A2:H2").Copy Destination:=Worksheets(AddShtName).Range("A" & EndRow)

　　'***** Sheet1をクリア
　　ws1.Activate
　　ws1.Range("A2:H2").ClearContents

　　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。　うまくいきました。

>>5 4で調べた空白行を次の行に貼り付ける・・・
No3のお礼欄に書いていますが、空白行=数式と書式が入力されており、値が入力されていない行のつもりです。

　　'***** 最終入力行を調べて貼り付け
　　Dim EndRow As Long '最終入力行の次の行
　　EndRow = Worksheets(AddShtName).Range("A65536").End(xlUp).Row + 1
　　ws1.Range("A2:H2").Copy Destination:=Worksheets(AddShtName).Range("A" & EndRow)

を次のようにして、おもいどおりの動作をするようになりました。

'***** 最終入力行を調べて貼り付け
Dim EndRow As Long '最終入力行の次の行
EndRow = Worksheets(AddShtName).Range("A65536").End(xlUp).Row + 1
Worksheets(AddShtName).Range("A" & EndRow & ":Z" & EndRow).Copy _
Destination:=Worksheets(AddShtName).Range("A" & EndRow + 1)
ws1.Range("A2:H2").Copy Destination:=Worksheets(AddShtName).Range("A" & EndRow)

また何か有ったら教えてください。

回答No.5

imogasi

逐次訳的に記します。止まるエラーは出ないと思いますが
内容的にどうでしょうか。質問でわからない点があります。
(補足要求）
＞4 Sheet200301の最後の空白行を調べる。(新しいシートを作って最初は2行目になってもらいたい)
－－－＞最初は3行目では
＞5 4で調べた空白行を次の行に貼り付ける。－－＞空白行を貼りつけるとは。空白行は貼りつけなくても良いのでは。
＞ 6 4で調べた空白行にSheet1のA2:H2を貼り付ける。
直前の5との関係で意味がよく取れない。
－－－－－－
Sub test01()
Dim sh1 As Worksheet
Dim sh As Worksheet
Set sh1 = Worksheets("sheet1")
'Sheet1のA2から、年月を取り出す。2003/1/1→200301
a1 = sh1.Cells(1, 1)
nengetu = Year(a1) & Month(a1)
nengetus = Trim(Str(nengetu))
'MsgBox "=" & nengetus
'シートの中に、Sheet200301が有るかどうか調べ
found = "n"
For Each sh In ActiveWorkbook.Worksheets
'MsgBox sh.Name
If sh.Name = nengetus Then
found = "y"
End If
Next
If found = "y" Then
Else
' 無かったらSheet200301というシートを作る。
ActiveWorkbook.Sheets.Add.Name = nengetus
End If
'Sheet4のA1:Z2をSheet200301に貼り付ける。
Worksheets("sheet4").Range("a1:z2").Copy
Worksheets(nengetus).Range("a1").Select
ActiveSheet.Paste
' Sheet200301の最後の空白行を調べる。
' (新しいシートを作って最初は2行目になってもらいたい)
d = Worksheets(nengetus).Range("a1").CurrentRegion.Rows.Count
' MsgBox d
'4で調べた空白行にSheet1のA2:H2を貼り付ける。
sh1.Range("a2:h2").Copy
Worksheets(nengetus).Cells(d, 1).Select
ActiveSheet.Paste
' Sheet1のA2:H2をクリアします
sh1.Range("a2:h2").Clear
End Sub

お礼

ありがとうございます。前にも、違う問題でも教えてもらい感謝しています。

＞＞4 Sheet200301の・・・ ＞5 ＞6　前のかたのお礼の欄に書いてありますが、書き方が非常にまずかったと反省しています。
また、最後の空白行は、最初の空白行の間違いです。

このマクロを次ぎのように変えて、最後まで流れるようになりました。
かってに変更してすみません。

Sub imogasi01()
Dim d
Dim found
Dim nengetus
Dim a1
Dim sh1 As Worksheet
Dim sh As Worksheet
Set sh1 = Worksheets("sheet1")
'Sheet1のA2から、年月を取り出す。2003/1/1→200301
'a1 = sh1.Cells(1, 1)
'nengetu = Year(a1) & Month(a1)
'nengetus = Trim(Str(nengetu))
Sheets("Sheet1").Select '******
nengetus = Format(Range("A2"), "yyyymm") '******
'MsgBox "=" & nengetus
'シートの中に、Sheet200301が有るかどうか調べ
found = "n"
For Each sh In ActiveWorkbook.Worksheets
'MsgBox sh.Name
If sh.Name = "Sheet" & nengetus Then
found = "y"
End If
Next
If found = "y" Then
Else
' 無かったらSheet200301というシートを作る。
ActiveWorkbook.Sheets.Add.Name = "Sheet" & nengetus
'Sheet4のA1:Z2をSheet200301に貼り付ける。
Worksheets("sheet4").Range("a1:z2").Copy
Worksheets("Sheet" & nengetus).Range("a1").Select
ActiveSheet.Paste

End If '******
' Sheet200301の最後の空白行を調べる。
' (新しいシートを作って最初は2行目になってもらいたい)
d = Worksheets("Sheet" & nengetus).Range("a1").CurrentRegion.Rows.Count
' MsgBox d
'4で調べた空白行を次の行に貼り付ける。
Sheets("Sheet" & nengetus).Select '*****
Worksheets("Sheet" & nengetus).Range(Cells(d + 1, 1), Cells(d + 1, 26)).Copy
Worksheets("Sheet" & nengetus).Cells(d + 2, 1).Select
ActiveSheet.Paste
'4で調べた空白行にSheet1のA2:H2を貼り付ける
sh1.Range("a2:h2").Copy
Sheets("Sheet" & nengetus).Select '*****
Worksheets("Sheet" & nengetus).Cells(d + 1, 1).Select
ActiveSheet.Paste
' Sheet1のA2:H2をクリアします
sh1.Range("a2:h2").Clear
End Sub

色々、勉強になりました。もう一度、皆さんにお礼申し上げます。

回答No.3

tksoft

色々問題がありますが、もう少し具体的にどの点が分からないかを、絞り込むとより良い答えが返ってくるものと思われます。
とりあえず最初に問題となりそうな点を。

(1)現在のワークブックのすべてのシート名を書き出す（おそらく、インデントが消えてしまい、ちょっと見難いかと・・・)
Sub SheetsList()
Dim MySheets As Variant
Dim i As Integer
i = 1
For Each MySheets In ActiveWorkbook.Sheets
Cells(i, 1).Value = Worksheets(i).Name
i = i + 1
Next
End Sub

(2)文字列の比較
StrComp 関数

(3)日付->文字列
Format(日付, "yyyymm")

(4)Sheet4がいきなり出てきますけどこれはいわゆるテンプレートですか？だとしたら、Sheet4をコピーして名前を変更すればよろしいかと、

＞4 Sheet200301の最後の空白行を調べる。(新しいシートを作って最初は2行目になってもらい たい)
すいません、ちょっと意味が分かりません。

(5)特定範囲のクリア
Sheets("Sheet1").Range("A2:H2").ClearContents

とりあえず、こんなもんでどうでしょう。

お礼

ありがとうございます。

>(1)現在のワークブックのすべてのシート名を書き出す
>Sub SheetsList()
シート名が表示されました。

>Sheet4をコピーして名前を変更すればよろしいかと、
そのとおりですね。でも方法がわかりません。

>>4 Sheet200301の最後の空白行を調べる。(新しいシートを作って最初は2行目になってもらい たい)
A1:Z1は、項目見出しです。
A2:Z2 (２行目)は、数式と書式が入力されています。
一回目は、２行目を３行目にコピー貼り付けをし、その後、A2:H2に入力する。
二回目は、３行目を４行目にコピー貼り付けをし、その後、A3:H3に入力する。
こういう風にしたかったのです。

回答No.2

imogasi

ワークシートの追加の部分だけ。
Sub test01()
ActiveWorkbook.Sheets.Add
End Sub
Sheetsとsをつけること。
今までsheet5まであればShhet6が出来る。
SheetsコレクションにAddするという意味。
同時に名前を「aaa」にしたかったら
ActiveWorkbook.Sheets.Add.Name = "aaa"

お礼

ありがとうございます。

参考にします。

回答No.1

taknt

エクセルのマクロを作るやり方の一つに マクロの記録というのがあります。
一連の操作を記憶してくれるのです。
それでやってみたらどうでしょうか？

というか、ちょっと量が多いので・・・。

お礼

ありがとうございます。

質問が多すぎました。反省します。