teratail
回答率
85.47%
質問するログイン新規登録
トップに関する質問配列に入った重複した値を一つにまとめたいです！

編集履歴

質問編集履歴

7

質問訂正

2019/03/08 03:24

投稿

chanken
chanken

スコア12

test CHANGED
File without changes
test CHANGED
@@ -64,6 +64,10 @@
64
64
 
65
65
  『インデックスが有効は範囲でにありません』
66
66
 
67
+ Function 重複削除(D_elements())内の
68
+
69
+ tmpAry(i) = dic.items(i) の部分でエラーが起きます。
70
+
67
71
 
68
72
 
69
73
  配列に入った重複した文字を一つにまとめたいのですがうまくいかないです。。。

6

質問タイトルの内容を修正

2019/03/08 03:23

投稿

chanken
chanken

スコア12

test CHANGED
@@ -1 +1 @@
1
- A,B,C,E判定列と書かれている列の全ての値が一致した時、一つの値にまとめ、残りのD、G列は、値が一緒であば同様に一つにまとめ、そうでなければ、記号で区切って、文字をまとめて出力したいです！
1
+ 配列に入った重複した値を一つにまとめたいです！
test CHANGED
@@ -66,6 +66,8 @@
66
66
 
67
67
 
68
68
 
69
+ 配列に入った重複した文字を一つにまとめたいのですがうまくいかないです。。。
70
+
69
71
  このエラーをどうなくすのか、他何か提案があれば知恵をおかりしたいです。
70
72
 
71
73
 

5

コードの追記

2019/03/07 21:50

投稿

chanken
chanken

スコア12

test CHANGED
File without changes
test CHANGED
@@ -62,7 +62,7 @@
62
62
 
63
63
 
64
64
 
65
- 『引数の数が正しくないか、またはプロパティの指定が無効です。』
65
+ 『インデックスが有効は範囲でにありません』
66
66
 
67
67
 
68
68
 
@@ -78,7 +78,67 @@
78
78
 
79
79
 
80
80
 
81
+ ```Sub 重複まとめ()
82
+
83
+
84
+
85
+ Worksheets.add After:=Worksheets(Worksheets.Count), Count:=1
86
+
87
+ ActiveSheet.Name = "Sheet2"
88
+
89
+ Sheets("Sheet1").Copy After:=Sheets("Sheet2")
90
+
91
+ ActiveSheet.Name = "Sheet3"
92
+
93
+
94
+
95
+ Call Test2
96
+
97
+
98
+
99
+ Call linking
100
+
101
+
102
+
103
+ End Sub
104
+
105
+
106
+
107
+
108
+
109
+ Sub Test2()
110
+
111
+ Worksheets("Sheet3").Activate
112
+
113
+ Dim SH As Worksheet
114
+
115
+ 'データの最終行を取得
116
+
117
+ Dim maxRow As Long
118
+
119
+
120
+
121
+ maxRow = Cells(Rows.Count, 3).End(xlUp).row
122
+
123
+
124
+
125
+
126
+
127
+
128
+
129
+ '重複しているデータを削除
130
+
131
+ Range("C3:H" & maxRow).RemoveDuplicates (Array(1, 2, 3, 5))
132
+
133
+
134
+
135
+
136
+
137
+ End Sub
138
+
139
+
140
+
81
- ```Sub linking()
141
+ Sub linking()
82
142
 
83
143
 
84
144
 
@@ -112,470 +172,530 @@
112
172
 
113
173
 
114
174
 
175
+ Dim d_i As Long
176
+
177
+ d_i = 4
178
+
179
+
180
+
181
+ '行カウントの変数
182
+
183
+ Dim row As Long
184
+
185
+ 'sheet2の行カウント
186
+
187
+ Dim i As Long
188
+
189
+ i = 4
190
+
191
+
192
+
193
+ Dim s_row As Long
194
+
195
+
196
+
197
+ s_row = 4
198
+
199
+
200
+
201
+ '開始行
202
+
203
+ '値があるまでループ（判定A列を基準）
204
+
205
+ For row = 4 To Cells(Rows.Count, 3).End(xlUp).row
206
+
207
+
208
+
209
+ '判定A列の値 を取得
210
+
211
+ n_rowA_value = Worksheets("Sheet3").Cells(row, 3).Value
212
+
213
+ p_rowA_value = Worksheets("Sheet3").Cells(row + 1, 3).Value
214
+
215
+
216
+
217
+ '判定B列の値 を取得
218
+
219
+ n_rowB_value = Worksheets("Sheet3").Cells(row, 4).Value
220
+
221
+ p_rowB_value = Worksheets("Sheet3").Cells(row + 1, 4).Value
222
+
223
+
224
+
225
+ '判定C列の値 を取得
226
+
227
+ n_rowC_value = Worksheets("Sheet3").Cells(row, 5).Value
228
+
229
+ p_rowC_value = Worksheets("Sheet3").Cells(row + 1, 5).Value
230
+
231
+
232
+
233
+ '判定E列の値 を取得
234
+
235
+ n_rowE_value = Worksheets("Sheet3").Cells(row, 7).Value
236
+
237
+ p_rowE_value = Worksheets("Sheet3").Cells(row + 1, 7).Value
238
+
239
+
240
+
241
+
242
+
243
+
244
+
245
+
246
+
247
+ '判定A~C,Eの値が全て重複するかを確認(重複が途切れた時Call文にてSheet2へ転記)
248
+
249
+ If n_rowA_value = p_rowA_value Then
250
+
251
+
252
+
253
+ If n_rowB_value = p_rowB_value Then
254
+
255
+
256
+
257
+ If n_rowC_value = p_rowC_value Then
258
+
259
+ If n_rowE_value = p_rowE_value Then
260
+
261
+ Else
262
+
263
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i)
264
+
265
+ End If
266
+
267
+ Else
268
+
269
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i)
270
+
271
+ End If
272
+
273
+ Else
274
+
275
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i)
276
+
277
+ End If
278
+
279
+ Else
280
+
281
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i)
282
+
283
+ End If
284
+
285
+
286
+
287
+ Next row
288
+
289
+
290
+
291
+
292
+
293
+ MsgBox "END"
294
+
295
+
296
+
297
+ End Sub
298
+
299
+
300
+
301
+
302
+
303
+ Sub no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i)
304
+
305
+
306
+
307
+ Dim g_row As Long
308
+
309
+
310
+
311
+ 'Sheet2へ重複した値を表記(判定A,B,C,E)
312
+
313
+ Worksheets("Sheet2").Cells(i, 3).Value = n_rowA_value
314
+
315
+ Worksheets("Sheet2").Cells(i, 4).Value = n_rowB_value
316
+
317
+ Worksheets("Sheet2").Cells(i, 5).Value = n_rowC_value
318
+
319
+ Worksheets("Sheet2").Cells(i, 7).Value = n_rowE_value
320
+
321
+
322
+
323
+
324
+
325
+ g_row = row
326
+
327
+
328
+
329
+ Call de_test(g_row, s_row, i, d_i)
330
+
331
+
332
+
333
+
334
+
335
+
336
+
337
+ i = i + 1
338
+
339
+
340
+
341
+ End Sub
342
+
343
+
344
+
345
+
346
+
347
+
348
+
349
+ Sub de_test(g_row, s_row, i, d_i)
350
+
351
+
352
+
353
+ Dim D_elements() As Variant
354
+
355
+
356
+
357
+
358
+
359
+ Dim cnt As Long
360
+
361
+ Dim l As Long
362
+
363
+ Dim D_output As Variant
364
+
365
+
366
+
367
+
368
+
369
+
370
+
371
+ l = 0
372
+
373
+
374
+
375
+
376
+
377
+ cnt = g_row - s_row
378
+
379
+ ReDim D_elements(cnt)
380
+
381
+
382
+
383
+ For l = 0 To cnt
384
+
385
+
386
+
387
+ D_elements(l) = Worksheets("Sheet3").Cells(d_i, 6).Value
388
+
115
389
 
116
390
 
117
-
118
-
119
- '行カウントの変数
120
-
121
- Dim row As Long
122
-
123
- 'sheet2の行カウント
124
-
125
- Dim i As Long
126
-
127
- i = 4
128
-
129
-
130
-
131
- Dim s_row As Long
132
-
133
-
134
-
135
- s_row = 4
136
-
137
-
138
-
139
- '開始行
140
-
141
- '値があるまでループ（判定A列を基準）
142
-
143
- For row = 4 To Cells(Rows.count, 3).End(xlUp).row
144
-
145
-
146
-
147
- '判定A列の値 を取得
148
-
149
- n_rowA_value = Worksheets("Sheet3").Cells(row, 3).Value
150
-
151
- p_rowA_value = Worksheets("Sheet3").Cells(row + 1, 3).Value
152
-
153
-
154
-
155
- '判定B列の値 を取得
156
-
157
- n_rowB_value = Worksheets("Sheet3").Cells(row, 4).Value
158
-
159
- p_rowB_value = Worksheets("Sheet3").Cells(row + 1, 4).Value
160
-
161
-
162
-
163
- '判定C列の値 を取得
164
-
165
- n_rowC_value = Worksheets("Sheet3").Cells(row, 5).Value
166
-
167
- p_rowC_value = Worksheets("Sheet3").Cells(row + 1, 5).Value
391
+ d_i = d_i + 1
392
+
393
+ Next l
394
+
395
+
396
+
397
+
398
+
399
+
400
+
401
+
402
+
403
+ 'D列の中身の重複を削除
404
+
405
+ Buf = 重複削除(D_elements)
406
+
407
+ '/記号を付加して代入
408
+
409
+
410
+
411
+ arry_cnt = UBound(D_elements) - LBound(D_elements) + 1
412
+
413
+
414
+
415
+
416
+
417
+ D_output = Join(D_elements, "/")
418
+
419
+ ' 出力
420
+
421
+ Worksheets("Sheet2").Cells(i, 6).Value = D_output
422
+
423
+
424
+
425
+
426
+
427
+
428
+
429
+ 'D列の配列を空にする
430
+
431
+ Erase D_elements
432
+
433
+
434
+
435
+
436
+
437
+ s_row = g_row + 1
438
+
439
+ Set dic = Nothing
440
+
441
+
168
442
 
169
443
 
170
444
 
171
- '判定E列の値 を取得
172
-
173
- n_rowE_value = Worksheets("Sheet3").Cells(row, 7).Value
174
-
175
- p_rowE_value = Worksheets("Sheet3").Cells(row + 1, 7).Value
176
-
177
-
178
-
179
-
180
-
181
-
182
-
183
-
184
-
185
- '判定A~C,Eの値が全て重複するかを確認(重複が途切れた時Call文にてSheet2へ転記)
186
-
187
- If n_rowA_value = p_rowA_value Then
188
-
189
-
190
-
191
- If n_rowB_value = p_rowB_value Then
192
-
193
-
194
-
195
- If n_rowC_value = p_rowC_value Then
196
-
197
- If n_rowE_value = p_rowE_value Then
198
-
199
- Else
200
-
201
- Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
202
-
203
- End If
204
-
205
- Else
206
-
207
- Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
208
-
209
- End If
210
-
211
- Else
212
-
213
- Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
214
-
215
- End If
445
+
446
+
447
+
448
+
449
+ End Sub
450
+
451
+
452
+
453
+ Function 重複削除(D_elements())
454
+
455
+ Dim dic As Class1
456
+
457
+ Set dic = New Class1
458
+
459
+ Dim i As Long
460
+
461
+ Dim items As Variant
462
+
463
+
464
+
465
+
466
+
467
+
468
+
469
+ For i = 0 To UBound(D_elements)
470
+
471
+ If dic.exists(D_elements(i)) = False Then
472
+
473
+ dic.add D_elements(i), D_elements(i)
474
+
475
+ End If
476
+
477
+ Next i
478
+
479
+
480
+
481
+
482
+
483
+
484
+
485
+ Dim tmpAry() As Variant
486
+
487
+ ReDim tmpAry(dic.Count - 1)
488
+
489
+
490
+
491
+ For i = 0 To UBound(tmpAry)
492
+
493
+
494
+
495
+ tmpAry(i) = dic.items(i)
496
+
497
+
498
+
499
+
500
+
501
+ Next i
502
+
503
+
504
+
505
+ 重複削除 = tmpAry
506
+
507
+
508
+
509
+ Set dic = Nothing
510
+
511
+
512
+
513
+
514
+
515
+ End Function
516
+
517
+ 　　　　　　　拾ってきたコード↓
518
+
519
+ ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
520
+
521
+ '''''''''''''
522
+
523
+ '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
524
+
525
+ Option Explicit
526
+
527
+
528
+
529
+
530
+
531
+ Private itemCount As Long
532
+
533
+ Private dictionaryKeys As New Collection
534
+
535
+ Private dictionaryValues As New Collection
536
+
537
+
538
+
539
+ Public Function add(ByVal Key As String, Value As Variant) As Variant
540
+
541
+ itemCount = itemCount + 1
542
+
543
+ If exists(Key) Then
544
+
545
+ add = dictionaryValues.Item(Key)
546
+
547
+ dictionaryValues.remove Key
548
+
549
+ dictionaryValues.add Value, Key
550
+
551
+ Else
552
+
553
+ dictionaryKeys.add Key, Key
554
+
555
+ dictionaryValues.add Value, Key
556
+
557
+ add = Null
558
+
559
+ End If
560
+
561
+ End Function
562
+
563
+
564
+
565
+ Public Function exists(ByVal Key As String) As Boolean
566
+
567
+ Dim aKey
568
+
569
+ Dim found As Boolean
570
+
571
+ found = False
572
+
573
+ For Each aKey In dictionaryKeys
574
+
575
+ If aKey = Key Then
576
+
577
+ found = True
578
+
579
+ Exit For
580
+
581
+ End If
582
+
583
+ Next aKey
584
+
585
+ exists = found
586
+
587
+ End Function
588
+
589
+
590
+
591
+ Public Function remove(ByVal Key As String) As Boolean
592
+
593
+ If exists(Key) Then
594
+
595
+ dictionaryKeys.remove Key
596
+
597
+ dictionaryValues.remove Key
598
+
599
+ itemCount = itemCount - 1
600
+
601
+ remove = True
602
+
603
+ Else
604
+
605
+ remove = False
606
+
607
+ End If
608
+
609
+ End Function
610
+
611
+
612
+
613
+ Public Sub removeAll()
614
+
615
+ itemCount = 0
616
+
617
+ Set dictionaryKeys = New Collection
618
+
619
+ Set dictionaryValues = New Collection
620
+
621
+ End Sub
622
+
623
+
624
+
625
+ Public Property Get count() As Long
626
+
627
+ count = itemCount
628
+
629
+ End Property
630
+
631
+
632
+
633
+ Public Property Get isEmpty() As Boolean
634
+
635
+ If itemCount = 0 Then
636
+
637
+ isEmpty = True
638
+
639
+ Else
640
+
641
+ isEmpty = False
642
+
643
+ End If
644
+
645
+ End Property
646
+
647
+
648
+
649
+
650
+
651
+ Public Function keys() As Collection
652
+
653
+ Set keys = dictionaryKeys
654
+
655
+ End Function
656
+
657
+
658
+
659
+ Public Function items() As Collection
660
+
661
+ Set items = dictionaryValues
662
+
663
+ End Function
664
+
665
+
666
+
667
+ 'This is the default property
668
+
669
+ Public Property Get Item(ByVal Key As String) As Variant
670
+
671
+ If exists(Key) Then
672
+
673
+ If TypeOf dictionaryValues.Item(Key) Is Object Then
674
+
675
+ Set Item = dictionaryValues.Item(Key)
216
676
 
217
677
  Else
218
678
 
219
- Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
679
+ Item = dictionaryValues.Item(Key)
220
-
680
+
221
- End If
681
+ End If
222
-
223
-
224
-
225
- Next row
226
-
227
-
228
-
229
-
230
-
231
- MsgBox "END"
232
-
233
-
234
-
235
- End Sub
236
-
237
-
238
-
239
-
240
-
241
- Sub no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
242
-
243
-
244
-
245
- Dim g_row As Long
246
-
247
-
248
-
249
- 'Sheet2へ重複した値を表記(判定A,B,C,E)
250
-
251
- Worksheets("Sheet2").Cells(i, 3).Value = n_rowA_value
252
-
253
- Worksheets("Sheet2").Cells(i, 4).Value = n_rowB_value
254
-
255
- Worksheets("Sheet2").Cells(i, 5).Value = n_rowC_value
256
-
257
- Worksheets("Sheet2").Cells(i, 7).Value = n_rowE_value
258
-
259
-
260
-
261
-
262
-
263
- g_row = row
264
-
265
-
266
-
267
- Call de_test(g_row, s_row, i)
268
-
269
-
270
-
271
-
272
-
273
-
274
-
275
- i = i + 1
276
-
277
-
278
-
279
- End Sub
280
-
281
-
282
-
283
-
284
-
285
-
286
-
287
- Sub de_test(g_row, s_row, i)
288
-
289
-
290
-
291
-
292
-
293
- Dim Dic As Class1
294
-
295
-
296
-
297
- 'キーと内容の変数を宣言
298
-
299
- Dim Key As Integer
300
-
301
- Dim D_element As Variant
302
-
303
- Dim D_elements As Variant
304
-
305
- Dim count As Long
306
-
307
-
308
-
309
-
310
-
311
-
312
-
313
- Dim d_i As Long
314
-
315
-
316
-
317
- '新しいDictionaryを作る
318
-
319
- Set Dic = New Class1
320
-
321
-
322
-
323
-
324
-
325
-
326
-
327
- For d_i = s_row To g_row
328
-
329
- D_element = Worksheets("Sheet3").Cells(d_i, 6).Value
330
-
331
- If Dic.exists(D_element) Then
332
-
333
- '登録済みの場合はカウントアップ
334
-
335
- Dic.Item(D_element) = CLng(Dic.Item(D_element)) + 1
336
682
 
337
683
  Else
338
684
 
339
- '未登録の場合は新規登録
340
-
341
- 'Value値はカウンターとして使用したいので、"1"をセット
342
-
343
- Dic.add D_element, 1
685
+ Item = False
344
-
345
-
346
686
 
347
687
  End If
348
688
 
349
-
350
-
351
-
352
-
353
- Next d_i
354
-
355
-
356
-
357
- D_elements = Dic.keys
358
-
359
-
360
-
361
- 'カウント値から重複の有無を判定
362
-
363
- For count = 0 To UBound(D_elements)
364
-
365
- If Dic.Item(D_elements(count)) > 1 Then
366
-
367
- 'カウント値が1より大きければ重複あり
368
-
369
- D_elements(count) = D_elements(count) & vbTab & "（重複あり）"
370
-
371
- End If
372
-
373
- Next
374
-
375
-
376
-
377
-
378
-
379
- Worksheets("Sheet2").Cells(i, 6).Value = D_elements
380
-
381
- 'キーを指定して内容を抽出
382
-
383
-
384
-
385
- D_element = ""
386
-
387
-
388
-
389
- s_row = g_row + 1
390
-
391
- Set Dic = Nothing
392
-
393
- End Sub
394
-
395
-
396
-
397
- 　　　　　　　拾ってきたコード↓
398
-
399
- ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
400
-
401
- '''''''''''''
402
-
403
- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
404
-
405
- Option Explicit
406
-
407
-
408
-
409
-
410
-
411
- Private itemCount As Long
412
-
413
- Private dictionaryKeys As New Collection
414
-
415
- Private dictionaryValues As New Collection
416
-
417
-
418
-
419
- Public Function add(ByVal Key As String, Value As Variant) As Variant
420
-
421
- itemCount = itemCount + 1
422
-
423
- If exists(Key) Then
424
-
425
- add = dictionaryValues.Item(Key)
426
-
427
- dictionaryValues.remove Key
428
-
429
- dictionaryValues.add Value, Key
430
-
431
- Else
432
-
433
- dictionaryKeys.add Key, Key
434
-
435
- dictionaryValues.add Value, Key
436
-
437
- add = Null
438
-
439
- End If
440
-
441
- End Function
442
-
443
-
444
-
445
- Public Function exists(ByVal Key As String) As Boolean
446
-
447
- Dim aKey
448
-
449
- Dim found As Boolean
450
-
451
- found = False
452
-
453
- For Each aKey In dictionaryKeys
454
-
455
- If aKey = Key Then
456
-
457
- found = True
458
-
459
- Exit For
460
-
461
- End If
462
-
463
- Next aKey
464
-
465
- exists = found
466
-
467
- End Function
468
-
469
-
470
-
471
- Public Function remove(ByVal Key As String) As Boolean
472
-
473
- If exists(Key) Then
474
-
475
- dictionaryKeys.remove Key
476
-
477
- dictionaryValues.remove Key
478
-
479
- itemCount = itemCount - 1
480
-
481
- remove = True
482
-
483
- Else
484
-
485
- remove = False
486
-
487
- End If
488
-
489
- End Function
490
-
491
-
492
-
493
- Public Sub removeAll()
494
-
495
- itemCount = 0
496
-
497
- Set dictionaryKeys = New Collection
498
-
499
- Set dictionaryValues = New Collection
500
-
501
- End Sub
502
-
503
-
504
-
505
- Public Property Get count() As Long
506
-
507
- count = itemCount
508
-
509
689
  End Property
510
690
 
511
691
 
512
692
 
513
- Public Property Get isEmpty() As Boolean
693
+ Public Property Let Item(ByVal Key As String, Value As Variant)
514
-
515
- If itemCount = 0 Then
694
+
516
-
517
- isEmpty = True
518
-
519
- Else
520
-
521
- isEmpty = False
695
+ Me.add Key, Value
522
-
523
- End If
524
696
 
525
697
  End Property
526
698
 
527
699
 
528
700
 
529
-
530
-
531
- Public Function keys() As Collection
532
-
533
- Set keys = dictionaryKeys
534
-
535
- End Function
536
-
537
-
538
-
539
- Public Function items() As Collection
540
-
541
- Set items = dictionaryValues
542
-
543
- End Function
544
-
545
-
546
-
547
- 'This is the default property
548
-
549
- Public Property Get Item(ByVal Key As String) As Variant
550
-
551
- If exists(Key) Then
552
-
553
- If TypeOf dictionaryValues.Item(Key) Is Object Then
554
-
555
- Set Item = dictionaryValues.Item(Key)
556
-
557
- Else
558
-
559
- Item = dictionaryValues.Item(Key)
560
-
561
- End If
562
-
563
- Else
564
-
565
- Item = False
566
-
567
- End If
568
-
569
- End Property
570
-
571
-
572
-
573
- Public Property Let Item(ByVal Key As String, Value As Variant)
574
-
575
- Me.add Key, Value
576
-
577
- End Property
578
-
579
-
580
-
581
701
  ```

4

コードの追記、質問の変更

2019/03/07 21:47

投稿

chanken
chanken

スコア12

test CHANGED
File without changes
test CHANGED
@@ -54,32 +54,528 @@
54
54
 
55
55
  現状、判定列　A,B,C,Eの部分をまとめるのは以下の記述でできたのですが
56
56
 
57
- 残りのD、G　写真の右の表のようにするための方法が、見つかりません。
58
-
59
-
60
-
61
- 引き出し不足で漠然な質問になりますが、どのようにしたら、そのような実装をできるのか知恵をお借りしたいです。
62
-
63
-
64
-
65
- ```ここ
66
-
67
- Sub Test2()
68
-
69
- 'データの最終行を取得
70
-
71
- Dim maxRow As Long
72
-
73
- maxRow = Cells(Rows.Count, 3).End(xlUp).row
74
-
75
-
76
-
77
- '重複しているデータを削除
78
-
79
- Range("C3:H" & maxRow).RemoveDuplicates (Array(1, 2, 3, 5))
80
-
81
- End Subに言語を入力
82
-
83
- コード
57
+ 残りのD、G　写真の右の表のようにするための実装に苦戦しています。
58
+
59
+
60
+
61
+ エラーメッセージ
62
+
63
+
64
+
65
+ 『引数の数が正しくないか、またはプロパティの指定が無効です。』
66
+
67
+
68
+
69
+ このエラーをどうなくすのか、他何か提案があれば知恵をおかりしたいです。
70
+
71
+
72
+
73
+ ※excelはmacの２０１６を使っています。・Dictionaryオブジェクトがmac版だと使えないのでクラスモジュールに、動作させるコードを拾って貼り付けてます。
74
+
75
+
76
+
77
+ 　　
78
+
79
+
80
+
81
+ ```Sub linking()
82
+
83
+
84
+
85
+ Worksheets("Sheet3").Activate
86
+
87
+
88
+
89
+ '判定 Aの比較変数
90
+
91
+ Dim p_rowA_value As Variant
92
+
93
+ Dim n_rowA_value As Variant
94
+
95
+ '判定Bの比較変数
96
+
97
+ Dim p_rowB_value As Variant
98
+
99
+ Dim n_rowB_value As Variant
100
+
101
+ '判定Cの比較変数
102
+
103
+ Dim p_rowC_value As Variant
104
+
105
+ Dim n_rowC_value As Variant
106
+
107
+ '判定のE比較変数
108
+
109
+ Dim p_rowE_value As Long
110
+
111
+ Dim n_rowE_value As Long
112
+
113
+
114
+
115
+
116
+
117
+
118
+
119
+ '行カウントの変数
120
+
121
+ Dim row As Long
122
+
123
+ 'sheet2の行カウント
124
+
125
+ Dim i As Long
126
+
127
+ i = 4
128
+
129
+
130
+
131
+ Dim s_row As Long
132
+
133
+
134
+
135
+ s_row = 4
136
+
137
+
138
+
139
+ '開始行
140
+
141
+ '値があるまでループ（判定A列を基準）
142
+
143
+ For row = 4 To Cells(Rows.count, 3).End(xlUp).row
144
+
145
+
146
+
147
+ '判定A列の値 を取得
148
+
149
+ n_rowA_value = Worksheets("Sheet3").Cells(row, 3).Value
150
+
151
+ p_rowA_value = Worksheets("Sheet3").Cells(row + 1, 3).Value
152
+
153
+
154
+
155
+ '判定B列の値 を取得
156
+
157
+ n_rowB_value = Worksheets("Sheet3").Cells(row, 4).Value
158
+
159
+ p_rowB_value = Worksheets("Sheet3").Cells(row + 1, 4).Value
160
+
161
+
162
+
163
+ '判定C列の値 を取得
164
+
165
+ n_rowC_value = Worksheets("Sheet3").Cells(row, 5).Value
166
+
167
+ p_rowC_value = Worksheets("Sheet3").Cells(row + 1, 5).Value
168
+
169
+
170
+
171
+ '判定E列の値 を取得
172
+
173
+ n_rowE_value = Worksheets("Sheet3").Cells(row, 7).Value
174
+
175
+ p_rowE_value = Worksheets("Sheet3").Cells(row + 1, 7).Value
176
+
177
+
178
+
179
+
180
+
181
+
182
+
183
+
184
+
185
+ '判定A~C,Eの値が全て重複するかを確認(重複が途切れた時Call文にてSheet2へ転記)
186
+
187
+ If n_rowA_value = p_rowA_value Then
188
+
189
+
190
+
191
+ If n_rowB_value = p_rowB_value Then
192
+
193
+
194
+
195
+ If n_rowC_value = p_rowC_value Then
196
+
197
+ If n_rowE_value = p_rowE_value Then
198
+
199
+ Else
200
+
201
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
202
+
203
+ End If
204
+
205
+ Else
206
+
207
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
208
+
209
+ End If
210
+
211
+ Else
212
+
213
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
214
+
215
+ End If
216
+
217
+ Else
218
+
219
+ Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
220
+
221
+ End If
222
+
223
+
224
+
225
+ Next row
226
+
227
+
228
+
229
+
230
+
231
+ MsgBox "END"
232
+
233
+
234
+
235
+ End Sub
236
+
237
+
238
+
239
+
240
+
241
+ Sub no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row)
242
+
243
+
244
+
245
+ Dim g_row As Long
246
+
247
+
248
+
249
+ 'Sheet2へ重複した値を表記(判定A,B,C,E)
250
+
251
+ Worksheets("Sheet2").Cells(i, 3).Value = n_rowA_value
252
+
253
+ Worksheets("Sheet2").Cells(i, 4).Value = n_rowB_value
254
+
255
+ Worksheets("Sheet2").Cells(i, 5).Value = n_rowC_value
256
+
257
+ Worksheets("Sheet2").Cells(i, 7).Value = n_rowE_value
258
+
259
+
260
+
261
+
262
+
263
+ g_row = row
264
+
265
+
266
+
267
+ Call de_test(g_row, s_row, i)
268
+
269
+
270
+
271
+
272
+
273
+
274
+
275
+ i = i + 1
276
+
277
+
278
+
279
+ End Sub
280
+
281
+
282
+
283
+
284
+
285
+
286
+
287
+ Sub de_test(g_row, s_row, i)
288
+
289
+
290
+
291
+
292
+
293
+ Dim Dic As Class1
294
+
295
+
296
+
297
+ 'キーと内容の変数を宣言
298
+
299
+ Dim Key As Integer
300
+
301
+ Dim D_element As Variant
302
+
303
+ Dim D_elements As Variant
304
+
305
+ Dim count As Long
306
+
307
+
308
+
309
+
310
+
311
+
312
+
313
+ Dim d_i As Long
314
+
315
+
316
+
317
+ '新しいDictionaryを作る
318
+
319
+ Set Dic = New Class1
320
+
321
+
322
+
323
+
324
+
325
+
326
+
327
+ For d_i = s_row To g_row
328
+
329
+ D_element = Worksheets("Sheet3").Cells(d_i, 6).Value
330
+
331
+ If Dic.exists(D_element) Then
332
+
333
+ '登録済みの場合はカウントアップ
334
+
335
+ Dic.Item(D_element) = CLng(Dic.Item(D_element)) + 1
336
+
337
+ Else
338
+
339
+ '未登録の場合は新規登録
340
+
341
+ 'Value値はカウンターとして使用したいので、"1"をセット
342
+
343
+ Dic.add D_element, 1
344
+
345
+
346
+
347
+ End If
348
+
349
+
350
+
351
+
352
+
353
+ Next d_i
354
+
355
+
356
+
357
+ D_elements = Dic.keys
358
+
359
+
360
+
361
+ 'カウント値から重複の有無を判定
362
+
363
+ For count = 0 To UBound(D_elements)
364
+
365
+ If Dic.Item(D_elements(count)) > 1 Then
366
+
367
+ 'カウント値が1より大きければ重複あり
368
+
369
+ D_elements(count) = D_elements(count) & vbTab & "（重複あり）"
370
+
371
+ End If
372
+
373
+ Next
374
+
375
+
376
+
377
+
378
+
379
+ Worksheets("Sheet2").Cells(i, 6).Value = D_elements
380
+
381
+ 'キーを指定して内容を抽出
382
+
383
+
384
+
385
+ D_element = ""
386
+
387
+
388
+
389
+ s_row = g_row + 1
390
+
391
+ Set Dic = Nothing
392
+
393
+ End Sub
394
+
395
+
396
+
397
+ 　　　　　　　拾ってきたコード↓
398
+
399
+ ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
400
+
401
+ '''''''''''''
402
+
403
+ '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
404
+
405
+ Option Explicit
406
+
407
+
408
+
409
+
410
+
411
+ Private itemCount As Long
412
+
413
+ Private dictionaryKeys As New Collection
414
+
415
+ Private dictionaryValues As New Collection
416
+
417
+
418
+
419
+ Public Function add(ByVal Key As String, Value As Variant) As Variant
420
+
421
+ itemCount = itemCount + 1
422
+
423
+ If exists(Key) Then
424
+
425
+ add = dictionaryValues.Item(Key)
426
+
427
+ dictionaryValues.remove Key
428
+
429
+ dictionaryValues.add Value, Key
430
+
431
+ Else
432
+
433
+ dictionaryKeys.add Key, Key
434
+
435
+ dictionaryValues.add Value, Key
436
+
437
+ add = Null
438
+
439
+ End If
440
+
441
+ End Function
442
+
443
+
444
+
445
+ Public Function exists(ByVal Key As String) As Boolean
446
+
447
+ Dim aKey
448
+
449
+ Dim found As Boolean
450
+
451
+ found = False
452
+
453
+ For Each aKey In dictionaryKeys
454
+
455
+ If aKey = Key Then
456
+
457
+ found = True
458
+
459
+ Exit For
460
+
461
+ End If
462
+
463
+ Next aKey
464
+
465
+ exists = found
466
+
467
+ End Function
468
+
469
+
470
+
471
+ Public Function remove(ByVal Key As String) As Boolean
472
+
473
+ If exists(Key) Then
474
+
475
+ dictionaryKeys.remove Key
476
+
477
+ dictionaryValues.remove Key
478
+
479
+ itemCount = itemCount - 1
480
+
481
+ remove = True
482
+
483
+ Else
484
+
485
+ remove = False
486
+
487
+ End If
488
+
489
+ End Function
490
+
491
+
492
+
493
+ Public Sub removeAll()
494
+
495
+ itemCount = 0
496
+
497
+ Set dictionaryKeys = New Collection
498
+
499
+ Set dictionaryValues = New Collection
500
+
501
+ End Sub
502
+
503
+
504
+
505
+ Public Property Get count() As Long
506
+
507
+ count = itemCount
508
+
509
+ End Property
510
+
511
+
512
+
513
+ Public Property Get isEmpty() As Boolean
514
+
515
+ If itemCount = 0 Then
516
+
517
+ isEmpty = True
518
+
519
+ Else
520
+
521
+ isEmpty = False
522
+
523
+ End If
524
+
525
+ End Property
526
+
527
+
528
+
529
+
530
+
531
+ Public Function keys() As Collection
532
+
533
+ Set keys = dictionaryKeys
534
+
535
+ End Function
536
+
537
+
538
+
539
+ Public Function items() As Collection
540
+
541
+ Set items = dictionaryValues
542
+
543
+ End Function
544
+
545
+
546
+
547
+ 'This is the default property
548
+
549
+ Public Property Get Item(ByVal Key As String) As Variant
550
+
551
+ If exists(Key) Then
552
+
553
+ If TypeOf dictionaryValues.Item(Key) Is Object Then
554
+
555
+ Set Item = dictionaryValues.Item(Key)
556
+
557
+ Else
558
+
559
+ Item = dictionaryValues.Item(Key)
560
+
561
+ End If
562
+
563
+ Else
564
+
565
+ Item = False
566
+
567
+ End If
568
+
569
+ End Property
570
+
571
+
572
+
573
+ Public Property Let Item(ByVal Key As String, Value As Variant)
574
+
575
+ Me.add Key, Value
576
+
577
+ End Property
578
+
579
+
84
580
 
85
581
  ```

3

表の追加

2019/03/07 08:49

投稿

chanken
chanken

スコア12

test CHANGED
File without changes
test CHANGED
@@ -1,3 +1,49 @@
1
+ || 判定 | 判定 | 判定 | | 判定 | | | | 判定 | 判定 | 判定 | | 判定 | |
2
+
3
+ |---|------|----------|--------|----------|------|-------|---|---|------|----------|--------|-----------|------|--------------|
4
+
5
+ | | A | B | C | D | E | G | | | A | B | C | D | E | G |
6
+
7
+ | 1 | 1111 | りんご | 国産 | 青森 | 100 | A商店 | | 1 | 1111 | りんご | 国産 | 青森 | 100 | A商店/B 商店 |
8
+
9
+ | 2 | 1111 | りんご | 国産 | 青森 | 100 | B商店 | | 2 | 2222 | みかん | 国産 | 和歌山 | 100 | C商店 |
10
+
11
+ | 3 | 2222 | みかん | 国産 | 和歌山 | 100 | C商店 | | 3 | 2222 | みかん | 国産 | 愛媛 | 500 | A商店 |
12
+
13
+ | 4 | 2222 | みかん | 国産 | 愛媛 | 500 | A商店 | | 4 | 2222 | マンゴー | 国産 | 沖縄/宮崎 | 500 | C商店 |
14
+
15
+ | 5 | 3333 | マンゴー | 国産 | 沖縄 | 50 | C商店 | | 5 | 3333 | マンゴー | 外国産 | メキシコ | 800 | D商店 |
16
+
17
+ | 6 | 3333 | マンゴー | 国産 | 宮崎 | 50 | C商店 | | | | | | | | |
18
+
19
+ | 7 | 3333 | マンゴー | 外国産 | メキシコ | 800 | D商店 | | | | | | | | |
20
+
21
+ | 8 | 1111 | りんご | 国産 | 青森 | 100 | A商店 | | | | | | | | |
22
+
23
+ | | | | | | | | | | | | | | | |
24
+
25
+
26
+
27
+
28
+
29
+
30
+
31
+
32
+
33
+
34
+
35
+
36
+
37
+
38
+
39
+
40
+
41
+
42
+
43
+
44
+
45
+
46
+
1
47
  ![イメージ説明](a88929619cade4a16032b6165f04d50c.png)
2
48
 
3
49
 

2

質問タイトルの内容を修正

2019/03/06 14:22

投稿

chanken
chanken

スコア12

test CHANGED
@@ -1 +1 @@
1
- A,B,C,E判定列と書かれている列の全ての値が一致した時、一つの値にまとめ、残りのD、G列は、値が一緒であば同様に一つにまとめ、そうでなければ、記号で区切って、文字を結合させて出力したいです！
1
+ A,B,C,E判定列と書かれている列の全ての値が一致した時、一つの値にまとめ、残りのD、G列は、値が一緒であば同様に一つにまとめ、そうでなければ、記号で区切って、文字をまとめて出力したいです！
test CHANGED
@@ -2,7 +2,7 @@
2
2
 
3
3
 
4
4
 
5
-
5
+ イメージとしましては写真の左の表から、右の表のように出力したいです。
6
6
 
7
7
 
8
8
 

1

コードの記述場所の修正

2019/03/06 10:33

投稿

chanken
chanken

スコア12

test CHANGED
File without changes
test CHANGED
@@ -16,7 +16,7 @@
16
16
 
17
17
 
18
18
 
19
- ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
19
+ ```ここ
20
20
 
21
21
  Sub Test2()
22
22
 
@@ -32,8 +32,8 @@
32
32
 
33
33
  Range("C3:H" & maxRow).RemoveDuplicates (Array(1, 2, 3, 5))
34
34
 
35
- End Sub
35
+ End Subに言語を入力
36
36
 
37
+ コード
37
38
 
38
-
39
- ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
39
+ ```