teratail
回答率
85.47%
質問するログイン新規登録
トップVBAに関する質問VBA:配列　Keyに紐づくItemの格納がうまくいかない

編集履歴

回答編集履歴

5

追記

2021/07/09 11:39

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -10,7 +10,7 @@
10
10
 
11
11
  If Not dc.Exists(List) Then
12
12
 
13
- dc.Add List, Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H"))
13
+ dc.Add List, Array(.Cells(I, "D"), .Cells(I, "M"), .Cells(I, "H"))
14
14
 
15
15
  End If
16
16
 
@@ -28,7 +28,7 @@
28
28
 
29
29
  List = .Cells(I, "E").Value
30
30
 
31
- dc(List) = Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H"))
31
+ dc(List) = Array(.Cells(I, "D"), .Cells(I, "M"), .Cells(I, "H"))
32
32
 
33
33
  Next I
34
34
 
@@ -54,7 +54,7 @@
54
54
 
55
55
  If Not dc.Exists(List) Then
56
56
 
57
- dc.Add List, Array(Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H")))
57
+ dc.Add List, Array(Array(.Cells(I, "D"), .Cells(I, "M"), .Cells(I, "H")))
58
58
 
59
59
  Else
60
60
 
@@ -62,7 +62,7 @@
62
62
 
63
63
  ReDim Preserve arr(UBound(arr) + 1)
64
64
 
65
- arr(UBound(arr)) = Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H"))
65
+ arr(UBound(arr)) = Array(.Cells(I, "D"), .Cells(I, "M"), .Cells(I, "H"))
66
66
 
67
67
  dc(List) = arr
68
68
 
@@ -155,3 +155,101 @@
155
155
 
156
156
 
157
157
  ```
158
+
159
+ ---
160
+
161
+ ```ここに言語を入力
162
+
163
+ Sub sample()
164
+
165
+ Dim wb1 As Workbook
166
+
167
+ Dim wb2 As Workbook
168
+
169
+
170
+
171
+ Dim ws1 As Worksheet
172
+
173
+ Dim ws2 As Worksheet
174
+
175
+ Dim ws3 As Worksheet
176
+
177
+
178
+
179
+ Set ws1 = wb1.Sheets("入力")
180
+
181
+ Set ws2 = wb2.Sheets("転記")
182
+
183
+
184
+
185
+ Dim dc As Scripting.Dictionary
186
+
187
+ Set dc = CreateObject("Scripting.Dictionary")
188
+
189
+
190
+
191
+ Dim inData, inCount
192
+
193
+ With ws1
194
+
195
+ inData = .Range(.Range("C9"), .Cells.SpecialCells(xlCellTypeLastCell)).Value
196
+
197
+ inCount = UBound(inData, 1)
198
+
199
+ End With
200
+
201
+
202
+
203
+ Dim i, k, arr
204
+
205
+ For i = 1 To inCount
206
+
207
+ k = inData(i, 5)
208
+
209
+ arr = Array(inData(i, 4), inData(i, 13), inData(i, 8), inData(i, 9) + inData(i, 10), inData(i, 11), inData(i, 12))
210
+
211
+ If Not dc.Exists(k) Then dc.Add k, CreateObject("Scripting.Dictionary")
212
+
213
+ dc(k).Add dc(k).Count, arr
214
+
215
+ Next
216
+
217
+
218
+
219
+ Dim j
220
+
221
+ j = 10
222
+
223
+ For Each k In dc
224
+
225
+ wb2.Sheets("転記").Copy After:=Worksheets(Worksheets.Count)
226
+
227
+ Set ws3 = wb2.Sheets("転記(2)")
228
+
229
+
230
+
231
+ With ws3
232
+
233
+ .Name = k
234
+
235
+ .Range("F4") = k
236
+
237
+ For Each arr In dc(k).Items
238
+
239
+ .Cells(j, 3).Resize(, 4).Value = Array(arr(0), arr(1), arr(2), arr(3))
240
+
241
+ .Cells(j + 1, 3).Resize(, 4).Value = Array(arr(0), arr(1), arr(2), arr(4))
242
+
243
+ j = j + 2
244
+
245
+ Next
246
+
247
+ End With
248
+
249
+ Next
250
+
251
+ End Sub
252
+
253
+
254
+
255
+ ```

4

修正

2021/07/09 11:38

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -142,11 +142,11 @@
142
142
 
143
143
 
144
144
 
145
- wb2.Sheets(List).Cells(I + dc(List), "C") = .Cells(I, "D").Value
145
+ wb2.Sheets(List).Cells(dc(List), "C") = .Cells(I, "D").Value
146
146
 
147
- wb2.Sheets(List).Cells(I + dc(List), "D") = .Cells(I, "M").Value
147
+ wb2.Sheets(List).Cells(dc(List), "D") = .Cells(I, "M").Value
148
148
 
149
- wb2.Sheets(List).Cells(I + dc(List), "E") = .Cells(I, "H").Value
149
+ wb2.Sheets(List).Cells(dc(List), "E") = .Cells(I, "H").Value
150
150
 
151
151
  dc(List) = dc(List) + 1
152
152
 

3

追記

2021/07/09 08:08

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -117,3 +117,41 @@
117
117
 
118
118
 
119
119
  ```
120
+
121
+ ---
122
+
123
+ ＜再追記＞
124
+
125
+ ```VBA
126
+
127
+ For I = 9 To wb2Row
128
+
129
+ List = .Cells(I, "E").Value
130
+
131
+ If Not dc.Exists(List) Then
132
+
133
+ wb2.Sheets("転記").Copy after:=Worksheets(Worksheets.Count)
134
+
135
+ wb2.Sheets("転記(2)").Name = List
136
+
137
+ wb2.Sheets(List).Range("F4") = List
138
+
139
+ dc(List) = 10
140
+
141
+ End If
142
+
143
+
144
+
145
+ wb2.Sheets(List).Cells(I + dc(List), "C") = .Cells(I, "D").Value
146
+
147
+ wb2.Sheets(List).Cells(I + dc(List), "D") = .Cells(I, "M").Value
148
+
149
+ wb2.Sheets(List).Cells(I + dc(List), "E") = .Cells(I, "H").Value
150
+
151
+ dc(List) = dc(List) + 1
152
+
153
+ Next I
154
+
155
+
156
+
157
+ ```

2

修正

2021/07/09 07:57

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -40,9 +40,39 @@
40
40
 
41
41
  ＜追記＞
42
42
 
43
+ やりたいことを取り違えていたようなので修正。
44
+
43
45
 
44
46
 
45
47
  ```VBA
48
+
49
+ Dim arr
50
+
51
+ For I = 9 To wb2Row
52
+
53
+ List = .Cells(I, "E").Value
54
+
55
+ If Not dc.Exists(List) Then
56
+
57
+ dc.Add List, Array(Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H")))
58
+
59
+ Else
60
+
61
+ arr = dc(List)
62
+
63
+ ReDim Preserve arr(UBound(arr) + 1)
64
+
65
+ arr(UBound(arr)) = Array(.Cells(I, "D"), .Cells(I, "M").Cells(I, "H"))
66
+
67
+ dc(List) = arr
68
+
69
+ End If
70
+
71
+
72
+
73
+ Next I
74
+
75
+
46
76
 
47
77
 
48
78
 
@@ -60,23 +90,27 @@
60
90
 
61
91
  wb2.Sheets("転記").copy after:=Worksheets(Worksheets.Count)
62
92
 
63
- wb2.Sheets("転記(2)").Range("F4") = dcKey 'Keyの転記
93
+ wb2.Sheets("転記(2)").Name = dcKey 'Keyの転記
64
94
 
95
+ wb2.Sheets(dcKey).Range("F4") = dcKey 'Keyの転記
65
96
 
97
+
66
98
 
67
- '------------------------------------------------------------------------------------
99
+ Dim v, j
68
100
 
69
- wb2.Sheets("転記(2)").Cells(I + 10, "C") = dcItem(0) 'Item1の転記-No.
101
+ j = 10
70
102
 
71
- wb2.Sheets("転記(2)").Cells(I + 10, "D") = dcItem(1) 'Item2の転記-Code
103
+ For Each v In dcItem
72
104
 
73
- wb2.Sheets("転記(2)").Cells(I + 10, "E") = dcItem(2) 'Ite3の転記-Name
105
+ wb2.Sheets(dcKey).Cells(I + j, "C") = v(0)
74
106
 
75
- '------------------------------------------------------------------------------------
107
+ wb2.Sheets(dcKey).Cells(I + j, "D") = v(1)
76
108
 
109
+ wb2.Sheets(dcKey).Cells(I + j, "E") = v(2)
77
110
 
111
+ j = j + 1
78
112
 
79
- wb2.Sheets("転記(2)").Name = dcKey 'Keyの転記
113
+ Next
80
114
 
81
115
  Next L
82
116
 

1

追記

2021/07/09 07:50

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -33,3 +33,53 @@
33
33
  Next I
34
34
 
35
35
  ```
36
+
37
+
38
+
39
+ ---
40
+
41
+ ＜追記＞
42
+
43
+
44
+
45
+ ```VBA
46
+
47
+
48
+
49
+ Dim dcKey, dcItem
50
+
51
+
52
+
53
+ For L = 0 To dc.Count - 1
54
+
55
+ dcKey = dc.Keys(L)
56
+
57
+ dcItem = dc.Items(L)
58
+
59
+
60
+
61
+ wb2.Sheets("転記").copy after:=Worksheets(Worksheets.Count)
62
+
63
+ wb2.Sheets("転記(2)").Range("F4") = dcKey 'Keyの転記
64
+
65
+
66
+
67
+ '------------------------------------------------------------------------------------
68
+
69
+ wb2.Sheets("転記(2)").Cells(I + 10, "C") = dcItem(0) 'Item1の転記-No.
70
+
71
+ wb2.Sheets("転記(2)").Cells(I + 10, "D") = dcItem(1) 'Item2の転記-Code
72
+
73
+ wb2.Sheets("転記(2)").Cells(I + 10, "E") = dcItem(2) 'Ite3の転記-Name
74
+
75
+ '------------------------------------------------------------------------------------
76
+
77
+
78
+
79
+ wb2.Sheets("転記(2)").Name = dcKey 'Keyの転記
80
+
81
+ Next L
82
+
83
+
84
+
85
+ ```