| |
▼yk さん：
★印、実際のシート名に変更願います。
Sub Sample()
Dim dic As Object
Dim c As Range
Dim w1 As Variant
Dim w2 As Variant
Dim d1 As Variant
Dim d2 As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") '★入力シート
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
w1 = Split(c.Offset(, 1).Value, "・")
w2 = Split(c.Offset(, 2).Value, "・")
If UBound(w1) >= 0 Or UBound(w2) >= 0 Then 'どちらかあれば
If UBound(w1) < 0 Then w1 = Array(Empty)
If UBound(w2) < 0 Then w2 = Array(Empty)
For Each d1 In w1
For Each d2 In w2
dic(dic.Count) = Array(c.Value, d1, d2)
Next
Next
End If
Next
End With
With Sheets("Sheet2") '★別シート
.UsedRange.Offset(1).ClearContents 'タイトル行以外クリア
.Range("A2").Resize(dic.Count, 3).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
On Error Resume Next
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).Delete xlToLeft
On Error GoTo 0
.Select
End With
End Sub
|
|
yk
- 16/10/24(月) 18:23 -
β
- 16/10/24(月) 16:58 -
yk
- 16/10/24(月) 0:30 -
