回答編集履歴
1
別解を追加しました。
test
CHANGED
|
@@ -50,3 +50,53 @@
|
|
|
50
50
|
End Sub
|
|
51
51
|
|
|
52
52
|
```
|
|
53
|
+
別解
|
|
54
|
+
System.Collections.ArrayListを使用しない方法です。
|
|
55
|
+
```VBA
|
|
56
|
+
Option Explicit
|
|
57
|
+
'クロス表作成
|
|
58
|
+
Public Sub CommandButton1_Click()
|
|
59
|
+
Dim dicT As Object
|
|
60
|
+
Dim keywd As Variant
|
|
61
|
+
Dim sh1 As Worksheet
|
|
62
|
+
Dim sh2 As Worksheet
|
|
63
|
+
Dim maxrow1 As Long
|
|
64
|
+
Dim row1 As Long
|
|
65
|
+
Dim row2 As Long
|
|
66
|
+
Dim key As Variant
|
|
67
|
+
Dim arr As Variant
|
|
68
|
+
Dim i As Long
|
|
69
|
+
Set dicT = CreateObject("Scripting.Dictionary")
|
|
70
|
+
Set sh1 = Worksheets("リスト1")
|
|
71
|
+
Set sh2 = Worksheets("リスト2")
|
|
72
|
+
keywd = Array("*A*", "*B*", "*C*", "*D*", "*E*")
|
|
73
|
+
'リスト2クリア
|
|
74
|
+
sh2.Rows("2:" & Rows.count).ClearContents
|
|
75
|
+
maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row 'A列の最大行取得
|
|
76
|
+
For row1 = 2 To maxrow1
|
|
77
|
+
key = sh1.Cells(row1, "A").Value
|
|
78
|
+
If dicT.exists(key) = False Then
|
|
79
|
+
arr = Array("", "", "", "", "", "")
|
|
80
|
+
dicT.Add key, arr
|
|
81
|
+
End If
|
|
82
|
+
arr = dicT(key)
|
|
83
|
+
For i = 0 To UBound(keywd)
|
|
84
|
+
If sh1.Cells(row1, "B").Value Like keywd(i) Then
|
|
85
|
+
arr(i) = sh1.Cells(row1, "B").Value
|
|
86
|
+
Exit For
|
|
87
|
+
End If
|
|
88
|
+
Next
|
|
89
|
+
dicT(key) = arr
|
|
90
|
+
Next
|
|
91
|
+
row2 = 2
|
|
92
|
+
For Each key In dicT.keys
|
|
93
|
+
sh2.Cells(row2, "A").Value = key
|
|
94
|
+
For i = 0 To UBound(keywd)
|
|
95
|
+
sh2.Cells(row2, 2 + i).Value = dicT(key)(i)
|
|
96
|
+
Next
|
|
97
|
+
row2 = row2 + 1
|
|
98
|
+
Next
|
|
99
|
+
sh2.Range("A1:F" & row2 - 1).Sort key1:=Range("A1"), Header:=xlYes
|
|
100
|
+
MsgBox ("完了")
|
|
101
|
+
End Sub
|
|
102
|
+
```
|