Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

329 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【75844】Re:パターン別に集計したいです。

kanabun - 14/7/13(日) 11:56 -


	引用なし

	パスワード

▼初心者さん： >《イメージ》 >【Sheet1】　　　　　　　　　　　　　　　 → パターン仕訳け >------------------------------------- >種別　1.　2.　3.　パターン　対象外 >A　　 1　　　　　　あ　　　　　　　　　→A の「あ」の行 >A　　 1　　　　　　あ　　　　　　　　　→A の「あ」の行 >A　　　　 1　　　　い　　　　　　　　　→A の「い」の行 >B　　　　 1　 1　　う　　　　　　　　　→B の「う」の行 >B　　　　 1　　　　　　　　　 S　　　　 →B の「対象外」の行 >C　　　　　　 1　　　　　　　　　　　　 →C の「調査中」の行 ' Sub Try1() 　　Dim i As Long, n As Long, m As Long 　　Dim dic As Object '種別を調べるための箱を用意します。　　Set dic = CreateObject("Scripting.Dictionary") 　　　　Dim r As Object 　　Dim v 　　Set r = Worksheets(1).[A1].CurrentRegion '表データを配列に入れる　　v = Intersect(r, r.Offset(1)).Value　　 '入れる（一行目は除く） '(1) 種別の種類を調べる → A,B,C 　　For i = 1 To UBound(v) 　　　　If Not dic.Exists(v(i, 1)) Then 　　　　　　n = n + 1 　　　　　　dic(v(i, 1)) = n 　　　　End If 　　Next　　'以上で種別 A(1), B(2), C(3) が完成()内は行番号　　 '(2) パターンの種類を調べる → 「あ」,「い」,「う」　　Dim dic2 As Object 　　Set dic2 = CreateObject("Scripting.Dictionary") 　　m = 0 　　For i = 1 To UBound(v)　　'5列目を調べる　　　　If Not IsEmpty(v(i, 5)) Then 　　　　　　If Not dic2.Exists(v(i, 5)) Then 　　　　　　　　m = m + 1 　　　　　　　　dic2(v(i, 5)) = m 　　　　　　End If 　　　　End If 　　Next '　パターンとしてはこれ以外に「対象外」「調査中」を追加。　　Dim mout&, mcho& 　　m = m + 1 　　dic2("対象外") = m: mout = m 　　m = m + 1 　　dic2("調査中") = m: mcho = m 　　 '(3) 以上が分ったら、 '　　種別の数だけ大きい箱を用意する '　　箱の中にパターンの数だけの小さい箱を入れる '　　そのパターン用の小さい箱のなかは 1. ｜ 2. ｜　3. の仕切りを入れる　　ReDim Ot(1 To n, 1 To m, 1 To 3) '　 ┌────────────────┐ 'n=1│種別A パターン　 1.　2.　3.　　 │ '　 │　　　1 あ　　　　　　　　　　 │ '　 │　　　2 い　　　　　　　　　　 │ '　 │　　　3 う　　　　　　　　　　 │ '　 │　　　4 対象外　　　　　　　　　│ '　 │　　　5 調査中　　　　　　　　　│ '　 └────────────────┘ 　　 '(4) もう一度Sheet1の表を上から順に読んでいって、データを仕分ける　　Dim j As Long, x As Long 　　For i = 1 To UBound(v) 　　　　n = dic(v(i, 1)) 　　　　If Not IsEmpty(v(i, 5)) Then 　　　　　　m = dic2(v(i, 5)) 　　　　Else 　　　　　　If v(i, 6) = "S" Then 　　　　　　　　m = mout 　　　　　　Else 　　　　　　　　m = mcho 　　　　　　End If 　　　　End If 　　　　'[1.][2.][3.]列の値１を調べる（あれば配列要素位置に加算）　　　　For j = 1 To 3 　　　　　　x = j + 1 　　　　　　If v(i, x) > 0 Then 　　　　　　　　Ot(n, m, j) = Ot(n, m, j) + v(i, x) 　　　　　　End If 　　　　Next 　　Next 　　 '(5)　Sheet2に種別の数だけカード型データベースを発行する　　Sheet2.Select 　　Sheet2.UsedRange.ClearContents 　　Dim a, b, c 　　Dim y As Long 　　y = 1 　　[A1:E1].Value = Split("種別パターン 1. 2. 3.") 　　For Each a In dic.Keys() 　　　　y = y + 1 　　　　Cells(y, 1).Value = a 　　　　n = dic(a) 　　　　For Each b In dic2.Keys() 　　　　　　y = y + 1 　　　　　　Cells(y, 2).Value = b 　　　　　　m = dic2(b) 　　　　　　For j = 1 To 3 　　　　　　　　If Ot(n, m, j) > 0 Then 　　　　　　　　　Cells(y, j + 2).Value = Ot(n, m, j) 　　　　　　　　End If 　　　　　　Next 　　　　Next 　　Next End Sub