VBAで差し込みシート作成はできないでしょうか？

質問

sb-yamatoと申します。よろしくお願いします。
ボランティア団体の登録者管理をしておりまして、エクセルVBAで人数分のシートを作成しながら差し込みができないかと悩んでいます。
イメージとしては、ワードの差し込み印刷をすると、人数分のページができると思います。それをエクセルシートでできないでしょうか？

自分なりに作ってはみたのですが、変数iの使い方が悪いのか、どうも上手くいきません。こんな感じです。
Sub シートの作成()
Dim touroku As Long　←登録番号です。（８桁）
Dim simei As String　←漢字氏名です。
Dim seinen As Date　 ←生年月日です。
Dim i As Byte　　　　←150人までです。
i = 2　　　　　　　　←１行目はタイトル行です。
Worksheets("名簿").Activate
Do While Cells(i, "B").Value <> ""
touroku = Range(i, "B").Value
simei = Range(i, "C").Value
seinen = Range(i, "D").Value
Worksheets("登録台帳（原本）").Copy After:=Worksheets(i)
Range("AI2").Value = touroku
Range("AJ2").Value = simei
Range("AK2").Value = seinen
ActiveSheets.Name = Range("AJ2").Value
i = i + 1
Loop
End Sub

名簿sheetのＢ列[変数i]行目をコピーしたsheetのセルAI2に貼り付けているつもりなのですが、反応してくれません。
皆様のお力添え、よろしくお願いいたします。

回答No.2

imogasi

もう＃１で解決したようだが、参考までに、VBA初心者用に
関数を出来るだけ使い、VBAは最小限と言う方法を紹介します。
ーー
Googleで「imogasi 請求書」でWEB照会してみてください。
http://oshiete1.goo.ne.jp/qa3538263.html
ほかたくさん出ます。
ーー
要点はデータのあるシートの空き列に連続番号を（手作業でよい）を
振る。
差込印刷をするシート側で、帳票見出し・項目見出し。罫線、書式の
設定は、合計の算出などはSheet2に対し、手作業でやる。そしてSheet2の空きセルに番号指定セル（Sheet1の現データの行を指定する）を設ける。
そして都度変わるデータは、INDIRECT関数で設定する。
例で説明すると
Sheet1で
A列　　B列
氏名　住所　＜－第１行目
大村　大田区　＜－第２行目
戸塚　調布市　＜－第３行目
・・・
Sheet２（印刷するシート）
A1に行番号指定セルを設ける（第1行目は印刷時には、印刷範囲には入れないようにする）
Sheet2の氏名を表示するセルには
=INDIRECT("sheet1!A"&A1)
を入れておく。
Sheet２のA1に2（Sheet1の２行目の人の意味）が入っていると
氏名は「大村」になります。A1に3と入れると氏名は「戸塚」に変わります。
この理屈を住所欄など他の印刷項目にも使います
ーー
その後VBAではSheet2のA1の値を2から最終行まで順次プログラムで自動で変化させ
For i=2 to 23
worksheets("heet2").range("A1")=i
'--Range指定と印刷のコードPrintOutを入れる。1行。
Next i
のたった４行で、質問者の２０行程度のコード以上の威力を発揮します。
最終行を捉えるコードが必要だが、簡単。
メリットは
関数に詳しい方には、シートを見て、何をやっているか安心感が有ると思う
（上記で、質問者のコード「以上」といった意味は下記２点）
少しコードの工夫すれば、特定の１人、２人など指定して、臨時にSheet2を印刷できる
Sheet2のレイアウトの修正にもVBAコードは一切触らなくて良い。

回答No.1

xls88

SheetをCopyするとActiveSheetが移動するのでSheet名を明示する必要があります。
Worksheets("名簿")はActivateしなくても大丈夫です。
Range(i, "B").Value といった書き方は出来ないです。
やるなら、Range("B" & i).Value です。
Copyで追加されたSheetがActiveSheetになります。
ActiveSheetのNameは変数simeiを使えばよいですね。

Sub testシートの作成()
　　Dim touroku As Long '←登録番号です。（８桁）
　　Dim simei As String '←漢字氏名です。
　　Dim seinen As Date '←生年月日です。
　　Dim i As Byte　　　　'←150人までです。
　　i = 2　　　　　　　　'←１行目はタイトル行です。
　　'Worksheets("名簿").Activate
　　With Worksheets("名簿")
　　　　Do While .Cells(i, "B").Value <> ""
　　　　　　touroku = .Cells(i, "B").Value
　　　　　　simei = .Cells(i, "C").Value
　　　　　　seinen = .Cells(i, "D").Value
　　　　　　Worksheets("登録台帳（原本）").Copy After:=Worksheets(i)
　　　　　　With ActiveSheet
　　　　　　　　.Range("AI2").Value = touroku
　　　　　　　　.Range("AJ2").Value = simei
　　　　　　　　.Range("AK2").Value = seinen
　　　　　　　　'.Name = Range("AJ2").Value
　　　　　　　　.Name = simei
　　　　　　End With
　　　　　　i = i + 1
　　　　Loop
　　End With
End Sub

お礼

早速のお返事ありがとうございました。
おかげ様で思い通りに動くようになりました。
ありがとうございました。