こんなマクロが必要になることがしょっちゅうあります。
Public Sub ラベルシート作成()
Dim 講座名列番号 As Long
Dim 資料名列番号 As Long
Dim 配布日列番号 As Long
Dim 配布No列番号 As Long
Dim ラベル対象列番号 As Long
講座名列番号 = 1
資料名列番号 = 2
配布日列番号 = 3
配布No列番号 = 4
ラベル対象列番号 = 5
Dim 成果物一覧 As Worksheet
Set 成果物一覧 = ActiveWorkbook.Worksheets("成果物一覧")
Dim 成果物一覧値複写 As Worksheet
Set 成果物一覧値複写 = ActiveWorkbook.Worksheets.Add
成果物一覧値複写.Name = "成果物一覧値複写"
成果物一覧.Cells.Copy
成果物一覧値複写.Cells.PasteSpecial Paste:=xlValues
' 講座名が空欄の箇所を埋める
Dim k As Long
k = 2
Do While 成果物一覧値複写.Cells(k, 資料名列番号).Value <> "" Or k < 300
Dim 講座名 As String
If 成果物一覧値複写.Cells(k, 講座名列番号).Value <> "" Then
講座名 = 成果物一覧値複写.Cells(k, 講座名列番号).Value
Else
成果物一覧値複写.Cells(k, 講座名列番号).Value = 講座名
End If
k = k + 1
Loop
成果物一覧値複写.Activate
成果物一覧値複写.Range("A2:F300") _
.Sort Key1:=Cells(1, 配布日列番号), order1:=xlAscending, _
Key2:=Cells(1, 配布No列番号), order2:=xlAscending
Dim ラベルシート As Worksheet
Set ラベルシート = ActiveWorkbook.Worksheets.Add
ラベルシート.Name = "ラベル"
Dim i As Long
i = 2
Dim j As Long
j = 1
Dim 研修名 As String
Dim 部数 As Long
研修名 = ActiveWorkbook.Worksheets("基礎情報").Cells(1, 2).Value
部数 = ActiveWorkbook.Worksheets("基礎情報").Cells(2, 2).Value
' 資料名が空欄にならない限り続ける
Do While 成果物一覧値複写.Cells(i, 資料名列番号).Value <> "" Or i < 300
Dim 資料名 As String
Dim 配布日 As String
Dim 配布No As String
If 成果物一覧値複写.Cells(i, 講座名列番号).Value <> "" Then
講座名 = 成果物一覧値複写.Cells(i, 講座名列番号).Value
End If
資料名 = 成果物一覧値複写.Cells(i, 資料名列番号).Value
配布日 = 成果物一覧値複写.Cells(i, 配布日列番号).Value
配布No = 成果物一覧値複写.Cells(i, 配布No列番号).Value
If 成果物一覧値複写.Cells(i, ラベル対象列番号) = "〇" Then
ラベルシート.Cells(j, 1).Value = _
"研修名:" & 研修名 & Chr(10) & _
"講座名:" & 講座名 & Chr(10) & _
"資料名:" & 資料名 & Chr(10) & _
"配布日:" & 配布日 & "日目" & Chr(10) & _
"配布No:" & 配布No & Chr(10) & _
"部数 :" & 部数 & Chr(10)
j = j + 1
End If
i = i + 1
Loop
End Sub
