- ベストアンサー
【エクセル】元データシートよりマクロで表を複数作成
- みんなの回答 (2)
- 専門家の回答
質問者が選んだベストアンサー
以下は、 作成したいひな形シートが"ひな形"として作成されている前提です。 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
その他の回答 (1)
- kkkkkm
- ベストアンサー率66% (1734/2604)
新しいシートの書式は変更していません。 新しいシート名はワイン名にします。 既にワイン名のシートがある場合そのデータはとばして次の行に移ります。 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
お礼
ありがとうございます。 参考になりました! とても助かります。
お礼
ありがとうございます。 まさにやりたいことができました! とても助かりました。