DBシートの内容をマクロで台帳にしたい

質問

マクロ初心者です。

エクセルのDBシートの内容をマクロで台帳にしたいのですが、マニュアル本を見てもなかなかうまくできません。

基本的には「DB」シートと、台帳原紙シートからなるエクセルファイルがあります。
「DB」シートのA列　A4：A500には商品の記号がならび、B列以降はその行の商品の固有情報が記載されています。　　例　A7　　商品αの記号　　　B7　　商品αの項目　　C7商品αの仕様・・・

台帳原紙シートは空欄の商品台帳となっております。

DBシートのA列の任意のセル（例　A14　記号名　「TEST-8」）を選択し、マクロを開始すると、台帳原紙シートをコピーして、そのシート名を「TEST-8」とし、台帳「TEST-8」のセルD1にDBシートのB7の記載情報をコピー。同じく台帳「TEST-8」のセルD5にDBシートのH7の記載情報をコピーしたいのです。

　なお、マクロを開始した際、すでに記号名と同じ名称のシートがある場合は、コピーせず、そのシートに飛ぶようにしたいと考えております。

Sub DB⇒台帳()
Dim Sheetname As String
On Error GoTo Er1
Sheetname = Cells(ActiveCell.Row, 5)
If Sheetname <> "" Then
Sheets("Orig.Sheet1").Select
Sheets("Orig.Sheet1").Copy Before:=Sheets(3)
End If
Er1:
End Sub

と見よう見真似でやってみたものの、既存のシートには飛べましたが、結果は散々・・・。

いろいろご指導をお願い申し上げます。

回答No.1

keithin · ベストアンサー

sub macro1()
　dim r as long
　dim SheetName as string

’準備
　if activesheet.name <> "DB" then exit sub
　r = activecell.row
　sheetname = cells(r, "A").value
　if sheetname = "" then exit sub

’転記
　on error goto errhandle
　worksheets(sheetname).range("D1").value = worksheets("DB").cells(r, "B").value
　worksheets(sheetname).range("D5").value = worksheets("DB").cells(r, "H").value
　worksheets(sheetname).select
　exit sub

’必要に応じてシート作成
errhandle:
　worksheets("台帳原紙").copy after:=worksheets(worksheets.count)
　activesheet.name = sheetname
　resume
end sub

お礼

keithin様
　早急なるご回答を賜りまして誠にありがとうございます。いまからご教示いただいた情報をもとに再度挑戦してみます。
　まずは取り急ぎお礼申し上げます。