エクセル マクロ シート作成 繰り返し

お世話になります。
最近VBAの勉強を始めた初心者ですが、下記内容のマクロを作成したく、お力添えをお願いします。

内容
シート１A列２行目～A列不定行までセル値が入っている。
シート１A列２行目を、シート２A列１行目に値貼り付けする。
シート２をコピーし、新規シートを作成。その際新規シート名はA列1行目のセル値にする。
その後新規シート内の全セルをコピーし、同シート内に値貼り付けする。
上記作業をシート1A列のセルが空白になる迄繰り返す。

以上、わかりずらいかと思いますが、何卒よろしくお願いします。

No.1 ベストアンサー 回答者： picopico_7 回答日時： 2016/06/08 10:14

こんにちは。

意図されていることに沿っているかが疑問ですが試しに作ってみました。
実際に動かしてみて修正が必要な箇所があるようでしたら補足下さい。

------------------------------------------------------------------------------
Sub a()

Dim dblROW As Double
Dim cnt As Double

'//----------------------------
'シート１の名前を指定
Const SNM1 = "Sheet1"

'シート２の名前を指定
Const SNM2 = "Sheet2"
'----------------------------//

'シート1のA列にデータが存在する行数を調べる
dblROW = 2
Do Until Len(Sheets(SNM1).Range("A" & dblROW)) = 0
dblROW = dblROW + 1
Loop
dblROW = dblROW - 1

'入力データが無い時は終了
If dblROW < 2 Then
Exit Sub
End If

For cnt = 2 To dblROW
'シート１のＡ列データをシート２に値貼り付け
Sheets(SNM1).Range("A" & cnt).Copy
Sheets(SNM2).Select
Sheets(SNM2).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues

'シート２を新規シートに値貼り付け
Sheets(SNM2).Copy after:=Sheets(Worksheets.Count)

'新規シートのシート名を付ける
Sheets(Worksheets.Count).Name = Sheets(SNM2).Range("A1")

'新規シートを値貼り付け
Sheets(Worksheets.Count).Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Sheets(Worksheets.Count).Range("A1").Select
Next

Sheets(SNM1).Select
Sheets(SNM1).Range("A1").Select
End Sub
------------------------------------------------------------------------------

この回答へのお礼

早速のご回答ありがとうございます。
お蔭さまで思い通りの結果が出ました！
本当にありがとうございました。

お礼日時：2016/06/08 21:32