|
▼ケイ さん:
3ヶ所追加、2ヶ所変更しています。
Sub Sample2()
Dim mRow As Long
Dim i As Long, k As Long
Dim v() As String
Dim c As Range
Dim sh2 As Worksheet '<==追加
Application.ScreenUpdating = False
Set sh2 = Sheets("Sheet2") '<==追加
i = 1
With Sheets("Sheet1")
mRow = WorksheetFunction.Max(.Range("A" & .Rows.Count).End(xlUp).Row, _
.Range("C" & .Rows.Count).End(xlUp).Row, _
.Range("E" & .Rows.Count).End(xlUp).Row)
.Columns("G").ClearContents
sh2.Columns("L").ClearContents '<==変更
For Each c In .Range("A1:A" & mRow)
k = 0
ReDim v(1 To 3)
If c.Value = 1 Then
k = k + 1
v(k) = "○○○"
End If
If c.Offset(0, 2).Value = 1 Then
k = k + 1
v(k) = "XXX"
End If
If c.Offset(0, 4).Value = 1 Then
k = k + 1
v(k) = "△△△"
End If
If k > 0 Then
ReDim Preserve v(1 To k)
c.Offset(0, 6).Value = Join(v, ",") 'G列
sh2.Cells(i, "L").Resize(k).Value = WorksheetFunction.Transpose(v) '<==変更
i = i + k
End If
Next
End With
Set sh2 = Nothing '追加
Application.ScreenUpdating = True
End Sub
|
|