|
▼ケイ さん:
こんばんは
要件を誤解していたらご容赦。
途中のフラッグを判定しているところが、ちょっとベタな感じでかっこ悪いのですが。
Option Explicit
Sub Sample()
Dim mRow As Long
Dim i As Long, k As Long
Dim v() As String
Dim c As Range
Application.ScreenUpdating = False
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
.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列
.Cells(i, "L").Resize(k).Value = WorksheetFunction.Transpose(v)
i = i + k
End If
Next
End With
Application.ScreenUpdating = True
End Sub
|
|