判定 | 判定 | 判定 | 判定 | 判定 | 判定 | 判定 | 判定 | |||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | G | A | B | C | D | E | G | |||
1 | 1111 | りんご | 国産 | 青森 | 100 | A商店 | 1 | 1111 | りんご | 国産 | 青森 | 100 | A商店/B 商店 | |
2 | 1111 | りんご | 国産 | 青森 | 100 | B商店 | 2 | 2222 | みかん | 国産 | 和歌山 | 100 | C商店 | |
3 | 2222 | みかん | 国産 | 和歌山 | 100 | C商店 | 3 | 2222 | みかん | 国産 | 愛媛 | 500 | A商店 | |
4 | 2222 | みかん | 国産 | 愛媛 | 500 | A商店 | 4 | 2222 | マンゴー | 国産 | 沖縄/宮崎 | 500 | C商店 | |
5 | 3333 | マンゴー | 国産 | 沖縄 | 50 | C商店 | 5 | 3333 | マンゴー | 外国産 | メキシコ | 800 | D商店 | |
6 | 3333 | マンゴー | 国産 | 宮崎 | 50 | C商店 | ||||||||
7 | 3333 | マンゴー | 外国産 | メキシコ | 800 | D商店 | ||||||||
8 | 1111 | りんご | 国産 | 青森 | 100 | A商店 | ||||||||
イメージとしましては写真の左の表から、右の表のように出力したいです。
現状、判定列 A,B,C,Eの部分をまとめるのは以下の記述でできたのですが
残りのD、G 写真の右の表のようにするための実装に苦戦しています。
エラーメッセージ
『インデックスが有効は範囲でにありません』
Function 重複削除(D_elements())内の
tmpAry(i) = dic.items(i) の部分でエラーが起きます。
配列に入った重複した文字を一つにまとめたいのですがうまくいかないです。。。
このエラーをどうなくすのか、他何か提案があれば知恵をおかりしたいです。
※excelはmacの2016を使っています。・Dictionaryオブジェクトがmac版だと使えないのでクラスモジュールに、動作させるコードを拾って貼り付けてます。
Sub
1 2 Worksheets.add After:=Worksheets(Worksheets.Count), Count:=1 3 ActiveSheet.Name = "Sheet2" 4 Sheets("Sheet1").Copy After:=Sheets("Sheet2") 5 ActiveSheet.Name = "Sheet3" 6 7 Call Test2 8 9 Call linking 10 11End Sub 12 13 14Sub Test2() 15Worksheets("Sheet3").Activate 16 Dim SH As Worksheet 17 'データの最終行を取得 18 Dim maxRow As Long 19 20 maxRow = Cells(Rows.Count, 3).End(xlUp).row 21 22 23 24 '重複しているデータを削除 25 Range("C3:H" & maxRow).RemoveDuplicates (Array(1, 2, 3, 5)) 26 27 28End Sub 29 30 Sub linking() 31 32 Worksheets("Sheet3").Activate 33 34 '判定 Aの比較変数 35 Dim p_rowA_value As Variant 36 Dim n_rowA_value As Variant 37 '判定Bの比較変数 38 Dim p_rowB_value As Variant 39 Dim n_rowB_value As Variant 40 '判定Cの比較変数 41 Dim p_rowC_value As Variant 42 Dim n_rowC_value As Variant 43 '判定のE比較変数 44 Dim p_rowE_value As Long 45 Dim n_rowE_value As Long 46 47 Dim d_i As Long 48 d_i = 4 49 50 '行カウントの変数 51 Dim row As Long 52 'sheet2の行カウント 53 Dim i As Long 54 i = 4 55 56 Dim s_row As Long 57 58 s_row = 4 59 60 '開始行 61 '値があるまでループ(判定A列を基準) 62 For row = 4 To Cells(Rows.Count, 3).End(xlUp).row 63 64 '判定A列の値 を取得 65 n_rowA_value = Worksheets("Sheet3").Cells(row, 3).Value 66 p_rowA_value = Worksheets("Sheet3").Cells(row + 1, 3).Value 67 68 '判定B列の値 を取得 69 n_rowB_value = Worksheets("Sheet3").Cells(row, 4).Value 70 p_rowB_value = Worksheets("Sheet3").Cells(row + 1, 4).Value 71 72 '判定C列の値 を取得 73 n_rowC_value = Worksheets("Sheet3").Cells(row, 5).Value 74 p_rowC_value = Worksheets("Sheet3").Cells(row + 1, 5).Value 75 76 '判定E列の値 を取得 77 n_rowE_value = Worksheets("Sheet3").Cells(row, 7).Value 78 p_rowE_value = Worksheets("Sheet3").Cells(row + 1, 7).Value 79 80 81 82 83 '判定A~C,Eの値が全て重複するかを確認(重複が途切れた時Call文にてSheet2へ転記) 84 If n_rowA_value = p_rowA_value Then 85 86 If n_rowB_value = p_rowB_value Then 87 88 If n_rowC_value = p_rowC_value Then 89 If n_rowE_value = p_rowE_value Then 90 Else 91 Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i) 92 End If 93 Else 94 Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i) 95 End If 96 Else 97 Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i) 98 End If 99 Else 100 Call no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i) 101 End If 102 103 Next row 104 105 106 MsgBox "END" 107 108End Sub 109 110 111Sub no_dupulication(n_rowA_value, n_rowB_value, n_rowC_value, n_rowE_value, i, row, s_row, d_i) 112 113 Dim g_row As Long 114 115 'Sheet2へ重複した値を表記(判定A,B,C,E) 116 Worksheets("Sheet2").Cells(i, 3).Value = n_rowA_value 117 Worksheets("Sheet2").Cells(i, 4).Value = n_rowB_value 118 Worksheets("Sheet2").Cells(i, 5).Value = n_rowC_value 119 Worksheets("Sheet2").Cells(i, 7).Value = n_rowE_value 120 121 122 g_row = row 123 124 Call de_test(g_row, s_row, i, d_i) 125 126 127 128 i = i + 1 129 130End Sub 131 132 133 134Sub de_test(g_row, s_row, i, d_i) 135 136Dim D_elements() As Variant 137 138 139Dim cnt As Long 140Dim l As Long 141Dim D_output As Variant 142 143 144 145 l = 0 146 147 148 cnt = g_row - s_row 149 ReDim D_elements(cnt) 150 151 For l = 0 To cnt 152 153 D_elements(l) = Worksheets("Sheet3").Cells(d_i, 6).Value 154 155 d_i = d_i + 1 156 Next l 157 158 159 160 161 'D列の中身の重複を削除 162 Buf = 重複削除(D_elements) 163 '/記号を付加して代入 164 165 arry_cnt = UBound(D_elements) - LBound(D_elements) + 1 166 167 168 D_output = Join(D_elements, "/") 169 ' 出力 170 Worksheets("Sheet2").Cells(i, 6).Value = D_output 171 172 173 174 'D列の配列を空にする 175 Erase D_elements 176 177 178 s_row = g_row + 1 179 Set dic = Nothing 180 181 182 183 184 End Sub 185 186 Function 重複削除(D_elements()) 187 Dim dic As Class1 188 Set dic = New Class1 189 Dim i As Long 190 Dim items As Variant 191 192 193 194 For i = 0 To UBound(D_elements) 195 If dic.exists(D_elements(i)) = False Then 196 dic.add D_elements(i), D_elements(i) 197 End If 198 Next i 199 200 201 202 Dim tmpAry() As Variant 203 ReDim tmpAry(dic.Count - 1) 204 205 For i = 0 To UBound(tmpAry) 206 207 tmpAry(i) = dic.items(i) 208 209 210 Next i 211 212 重複削除 = tmpAry 213 214 Set dic = Nothing 215 216 217End Function 218 拾ってきたコード↓ 219==================================================== 220''''''''''''' 221''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 222Option Explicit 223 224 225 Private itemCount As Long 226 Private dictionaryKeys As New Collection 227 Private dictionaryValues As New Collection 228 229 Public Function add(ByVal Key As String, Value As Variant) As Variant 230 itemCount = itemCount + 1 231 If exists(Key) Then 232 add = dictionaryValues.Item(Key) 233 dictionaryValues.remove Key 234 dictionaryValues.add Value, Key 235 Else 236 dictionaryKeys.add Key, Key 237 dictionaryValues.add Value, Key 238 add = Null 239 End If 240 End Function 241 242 Public Function exists(ByVal Key As String) As Boolean 243 Dim aKey 244 Dim found As Boolean 245 found = False 246 For Each aKey In dictionaryKeys 247 If aKey = Key Then 248 found = True 249 Exit For 250 End If 251 Next aKey 252 exists = found 253 End Function 254 255 Public Function remove(ByVal Key As String) As Boolean 256 If exists(Key) Then 257 dictionaryKeys.remove Key 258 dictionaryValues.remove Key 259 itemCount = itemCount - 1 260 remove = True 261 Else 262 remove = False 263 End If 264 End Function 265 266 Public Sub removeAll() 267 itemCount = 0 268 Set dictionaryKeys = New Collection 269 Set dictionaryValues = New Collection 270 End Sub 271 272 Public Property Get count() As Long 273 count = itemCount 274 End Property 275 276 Public Property Get isEmpty() As Boolean 277 If itemCount = 0 Then 278 isEmpty = True 279 Else 280 isEmpty = False 281 End If 282 End Property 283 284 285 Public Function keys() As Collection 286 Set keys = dictionaryKeys 287 End Function 288 289 Public Function items() As Collection 290 Set items = dictionaryValues 291 End Function 292 293 'This is the default property 294 Public Property Get Item(ByVal Key As String) As Variant 295 If exists(Key) Then 296 If TypeOf dictionaryValues.Item(Key) Is Object Then 297 Set Item = dictionaryValues.Item(Key) 298 Else 299 Item = dictionaryValues.Item(Key) 300 End If 301 Else 302 Item = False 303 End If 304 End Property 305 306 Public Property Let Item(ByVal Key As String, Value As Variant) 307 Me.add Key, Value 308 End Property 309
DとGを結合したものを列挙しないと、分からなくなりませんか?
質問は編集できますので新しい質問を立てるのではなく、多重投稿の場合でも片方削除して残した方を編集して質問を充実させてください。
また、コードはマークダウンのcode機能を利用してご提示ください
ご指摘ありがとうございます。
シートのデータ例も、画像ではななくマークダウン記法のテーブルで記述してもらうと、回答者はデータ入力せずにコピーしてシートに貼り付けるだけで済むので楽なんだか。下記を使うとエクセルからコピーしたものをマークダウンテーブルに変換してくれるので楽です。
http://www.tablesgenerator.com/markdown_tables
このようなものがあったんですね、ご丁寧にありがとうございます。早速使わせていただきます!
回答5件
あなたの回答
tips
プレビュー