【エクセル】元データシートよりマクロで表を複数作成

質問

はじめまして。

ワインの情報が入った元データシートよりマクロを使って
それぞれ違うシートに表を複数作成したいのですが、
上手くいきません。
教えていただけますでしょうか。

元データには
ワイン名、ヴィンテージ、産地、ブドウ品種の情報があります。

そこから各ワインごとの表を別シートに一度に作成したいです。
添付画像をご参照ください。

ご教授いただけますと幸いです。
よろしくお願いいたします。

回答No.1

HohoPapa · ベストアンサー

以下は、
作成したいひな形シートが"ひな形"として作成されている前提です。

Sub kkk()

　Dim RowCnt As Long
　Dim wsM As Worksheet
　Dim wsS As Worksheet

　Set wsM = ThisWorkbook.Sheets("元データ")

　RowCnt = 2
　Do
　　If wsM.Cells(RowCnt, 1).Value = "" Then Exit Do
　　Sheets("ひな形").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
　　ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Format(RowCnt - 1, "0")
　　Set wsS = ThisWorkbook.Sheets(Format(RowCnt - 1, "0"))
　　wsS.Cells(1, 2).Value = wsM.Cells(RowCnt, 2).Value
　　wsS.Cells(2, 2).Value = wsM.Cells(RowCnt, 3).Value
　　wsS.Cells(3, 2).Value = wsM.Cells(RowCnt, 4).Value
　　wsS.Cells(4, 2).Value = wsM.Cells(RowCnt, 5).Value
　　RowCnt = RowCnt + 1
　Loop

End Sub

お礼

ありがとうございます。
まさにやりたいことができました！
とても助かりました。

回答No.2

kkkkkm

新しいシートの書式は変更していません。
新しいシート名はワイン名にします。
既にワイン名のシートがある場合そのデータはとばして次の行に移ります。

Sub Example()
Dim ws As Worksheet, Ws1 As Worksheet, NewWs As Worksheet
Dim i As Long, flag As Boolean

Set Ws1 = Sheets("元データ")

With Ws1
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
flag = False
For Each ws In Worksheets
If ws.Name = .Cells(i, "A").Value Then
flag = True
Exit For
End If
Next ws
If flag = True Then
MsgBox "既に　" & .Cells(i, "A").Value & "　名のシートがあります。", vbInformation
Else
Set NewWs = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWs.Name = .Cells(i, "A").Value
NewWs.Range("A1").Resize(4, 1) = _
WorksheetFunction.Transpose(Array(.Range("A1").Value, .Range("B1").Value, .Range("C1").Value, .Range("D1").Value))
NewWs.Range("B1").Resize(4, 1) = _
WorksheetFunction.Transpose(Array(.Cells(i, "A").Value, .Cells(i, "B").Value, .Cells(i, "C").Value, .Cells(i, "D").Value))
End If
Set NewWs = Nothing
Next
End With
Set Ws1 = Nothing
End Sub

お礼

ありがとうございます。
参考になりました！
とても助かります。