- ベストアンサー
Scripting.Dictionaryについて
- VBAでScripting.Dictionaryを使用してリストボックスに値を代入するコードを理解できない
- リストボックスに値を代入する際に、重複を除いて順番に代入される
- オートフィルタで抽出した値をScripting.Dictionaryに格納してリストボックスに代入する
- mimoule1998
- お礼率37% (37/100)
- オフィス系ソフト
- 回答数2
- ありがとう数1
- みんなの回答 （2）
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (1)
- end-u
- ベストアンサー率79% (496/625)
Set CC = RR.Columns("H:I") Set SS = RR.Columns("J") ...として '： Application.Intersect(CC, CC.Offset(1)).Copy With New DataObject .GetFromClipboard v = Split(.GetText, vbCrLf) Application.Intersect(SS, SS.Offset(1)).Copy .GetFromClipboard x = Split(.GetText, vbCrLf) End With With CreateObject("Scripting.Dictionary") For i = 0 To UBound(v) - 1 If .exists(v(i)) Then ary = .Item(v(i)) ary(0) = ary(0) + CDbl(x(i)) ary(1) = ary(1) + 1 .Item(v(i)) = ary Else .Item(v(i)) = Array(CDbl(x(i)), 1) End If Next ReDim myList(1 To .Count, 3) i = 0 For Each v In .Keys i = i + 1 'キーをvbTabで分割 ary = Split(v, vbTab) myList(i, 0) = ary(0) 'H列の値 myList(i, 1) = ary(1) 'I列の値 myList(i, 2) = .Item(v)(0) 'J列の計 myList(i, 3) = .Item(v)(1) 'H,I列値のカウント数 Next '： こんな感じでしょうか。 パターン１と２の組み合わせですね。 J列値のエラー対策など、いろいろ工夫してみてください。 "Scripting.Dictionary"の基本についてなら以下参考。 http://msdn.microsoft.com/ja-jp/library/cc428065.aspx http://www.geocities.jp/cbc_vbnet/Scripting/dictionary.html では、私はこの辺で。がんばってください。 #今回のケースだと、ピボットテーブルを応用したほうが良さそうな気がしなくもないけど。
お礼
end-uさん 貴重なアドバイスありがとうございました。 いろいろ工夫しながら動作を覚えていきたいと思います。
関連するQ&A
- マクロdictionaryオブジェクト書き換え
ここで教えていただいたマクロを シート1のＦ列を検索値として シート2のＡ列を検索しヒットしたら シート2の該当行のＤ列をシート1のＡＥ列に転記。 データの２列目から行う。ヒットしない場合は 無 と転記。 と変更したくて記述を書き換えたらシート1が壊れてしまいました。 正しい記述を教えてください。 ↓教えていただいた書き換え前の正常動作する記述↓ Sub 検索() 'dictionaryオブジェクトを使用 'シート1のＡ列を検索値として 'シート2のＡ列を検索しヒットしたら 'シート2の該当行のＥ列をシート1のＣ列に転記 'データの２行目から行う。ヒットしない場合は無しと転記 Dim dic As Object Dim i As Long Dim v, w Dim t As Single t = Timer With Sheets("Sheet2") '返す値を指定E列 With .Range("E2", .Cells(.Rows.Count, 1).End(xlUp)) '検索する列指定 (1)=A列 v = .Columns(1).Value '返す値のある列指定 (5)=E列 w = .Columns(5).Value End With End With Set dic = CreateObject("scripting.dictionary") For i = 1 To UBound(v) dic(v(i, 1)) = i Next With Sheets("Sheet1") '検索値のある列指定 A列 With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) v = .Value For i = 1 To UBound(v) If dic.exists(v(i, 1)) Then v(i, 1) = w(dic(v(i, 1)), 1) Else v(i, 1) = "無" End If Next '転記する列を指定 Offset(, 2)=検索値のA列より右2つ→C列 With .Offset(, 2) .ClearContents .Value = v End With End With End With Set dic = Nothing Debug.Print Timer - t End Sub ---- ↓書き換えておかしな動きになった物 ●の部分を変更しました↓ Sub 検索02() 'dictionaryオブジェクトを使用 'シート1のＦ列を検索値として 'シート2のＡ列を検索しヒットしたら 'シート2の該当行のＤ列をシート1のAE列に転記 'データの２行目から行う。ヒットしない場合は無しと転記 Dim dic As Object Dim i As Long Dim v, w Dim t As Single t = Timer With Sheets("Sheet2") '返す値を指定D列● With .Range("D2", .Cells(.Rows.Count, 1).End(xlUp)) '検索する列指定 (1)=A列 v = .Columns(1).Value '返す値のある列指定 (4)=D列● w = .Columns(4).Value End With End With Set dic = CreateObject("scripting.dictionary") For i = 1 To UBound(v) dic(v(i, 1)) = i Next With Sheets("Sheet1") '検索値のある列指定 F列● With .Range("F2", .Cells(.Rows.Count, 1).End(xlUp)) v = .Value For i = 1 To UBound(v) If dic.exists(v(i, 1)) Then v(i, 1) = w(dic(v(i, 1)), 1) Else v(i, 1) = "無" End If Next '転記する列を指定 'Offset(, 25)=検索値のA列より右25個→AE列● With .Offset(, 25) .ClearContents .Value = v End With End With End With Set dic = Nothing Debug.Print Timer - t End Sub
- ベストアンサー
- オフィス系ソフト
- VBA シートプログラムでRangeエラー
いつもお世話になっております。 Excel2003を使用しております。 シートに直接プログラムを書いています。 （例として、Sheet1とします） シートの内容が変わったときに、色々プログラムを実行していこうと思っているのですが、 Private Sub Worksheet_Change(ByVal Target As Range) のTargetが上手く取得できていない気がします。 今までは上手く動いていたのですが、 急にTargetの値に数値（セルに入力した値）が入ってしまうようになり 上手く組めなくて困っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim 開始1 As Range Dim 終了1 As Range Dim 開始2 As Range Dim 終了2 As Range Set 開始1 = Range("D5：D63") Set 終了1 = Range("E5：E63") Set 開始2 = Range("F5：F63") Set 終了2 = Range("G5：G63") If ThisWorkbook.ActiveSheet.ProtectContents Then '保護かかってたら End '強制終了 End If If Not Application.Intersect(Target, 開始1) Or Application.Intersect(Target, 実績日開始2) Is Nothing Then Call 開始(Target, 開始1, 開始2) ElseIf Not Application.Intersect(Target, 終了1) Or Application.Intersect(Target, 終了2) Is Nothing Then Msgbox "テスト！" End If End Sub '----------------------------------------------- Sub 開始(ByVal Target As Range, 開始1 As Range, 開始2 As Range) If Not Application.Intersect(Target, 開始1) Is Nothing Then MsgBox Target.Row End If If Not Application.Intersect(Target, 開始2) Is Nothing Then MsgBox Target.Row + 1 End If End Sub 全部シートに書いています。 まだ、テスト段階のため適当なプログラムしか書いておりません。 （指定範囲が変更された場合に、Msgboxを出したりなど 単純なことしかしていません） どこが悪いのか、教えて頂けないでしょうか？ よろしくお願い致します。
- ベストアンサー
- Excel（エクセル）
- Excelマクロ
お世話になります。 Excelのマクロに関する質問です。 目的としては、D列に様々な文言が入っており、 D列に記入されている各文言の数をカウントしたいと思っています。 ただし、D列の各文言が複数あった場合でも、 A列が同じ値の場合は数に含めない、という条件があります。 ex)D列に「りんご」という文言が10個あります。 D列に「りんご」と記入されている行のA列は、 「赤」「青」の2パターンしかありません。 ⇒この場合、「2」とカウントしたいです。 現在、以下のマクロを考えています。 =========================================================== sub test() Dim i As Long, x As Long, cnt As Long, buf As Object '「i」「x」「cnt」を数値として定義。「buf」にD列の値を格納します。 x = 4 '4行目以降を対象としています。 Do While Cells(x, 1).Value <> "" 'A列が空白でない場合のみを対象とします。 cnt = 0 '各行のD列に入っている値の数を数えるため、まずはカウントを0にします。 i = 4 '4行目以降を対象としています。 Set buf = Cells(x, 4) ' D列の値を変数「buf」に格納します。 Do While Cells(i, 1).Value <> "" 'A列が空白でない場合のみを対象とします。 If Cells(i, 4).Value = buf And Cells(i, 1).Value <> Cells(x, 1).Value Then ' D列の値が「buf」に格納した値と同じ、かつ、 ' A列の値が、bufに値を格納した時と異なる場合のみ対象 cnt = cnt + 1 '数を数える対象であれば、+1します。 End If i = i + 1 '次の行に移るために+1します。 Loop Cells(x, 5).Value = cnt ' E列にcntに格納された値を入力 x = x + 1 '次の行に移るために+1します。 Loop end sub ===================================================== 上記のマクロでは、E列にカウント後の数らしいものが入力されるのですが、 値が正しくないようです。 お力添えをいただけますでしょうか。 よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- 二次元のDictionary
ASPは全くの初心者です。 今回、二次元のDictionaryを使って値を表示させたいのですが 行き詰ってしまいました。 以下のコードをどのように変換すれば良いですか？ <%@ LANGUAGE = VBSCRIPT %> <% call dictionary_create() Sub dictionary_create() Dim objParent Dim objChild dim x Set objParent = CreateObject("Scripting.Dictionary") For x=0 to 9 Set objChild = CreateObject("Scripting.Dictionary") objChild.Add "kaigi", "会議名"&i objChild.Add "Id", "0"&i objParent.Add x, objChild Set objChild = Nothing Response.Write objParent.Item("ConfName") Next end sub %>
- 締切済み
- Microsoft ASP
- エクセル ご教示ください。
sheet1に罫線入りの基礎データがあります。 タイトルにてフィルターにてデータを抽出して、タイトルを除くデーターのみsheet2に貼り付けるのですが、貼り付ける際に、罫線も一緒に貼り付いてしまいます。 どのようにすれば罫線を除くデータのみ貼り付けることができるのかご教示願います。 Sub 転記(1)() Dim RR As Range Set RR = ActiveCell.Worksheet.AutoFilter.Range Set RR = Intersect(RR.SpecialCells(xlCellTypeVisible), RR.Offset(1)) RR.Copy Sheets("Sheet2").Range("A5") End Sub
- ベストアンサー
- Excel（エクセル）
- マクロの修正をお願いします
前回と前々回の質問で、マクロを作成していただき とても作業が楽になったのですが、一部変更してもらいたい点があり 再度質問させていただきます（何度も申し訳ありません） 自分でなんとかできないかと思ったのですが、どうにもできず・・すみません。 前回の質問へのリンク：http://okwave.jp/qa4383630.html D列から抽出した数値を、E～Qに書き出すように作成していただきました。 この書き出し先を「A列に数字が入っている行のE～Q」に変更していただきたいです。 (A1に数字が入っていたら、E1～Q1に書き出すようなかたち) A列には数行置きに数字が入っております。数字は全て半角英数です。 数字以外は、全て空欄のセルです（A1に数字、A2～A5まで空欄、A6に数字というような感じです） 本当に何度も申し訳ないのですが、急ぎませんので修正できる方がいらっしゃいましたらお願いします。 前回の質問で作成していただいたマクロはこちらです。 Sub test() Dim RegExp As Object Dim r As Range Dim rr As Range, rs As Range Dim i As Integer, j As Integer Dim match, v ReDim v(1 To 1, 1 To 6) Set RegExp = CreateObject("VBScript.Regexp") RegExp.Pattern = "\d+" RegExp.Global = True i = 7 For Each r In Range("D1", Cells(Rows.Count, 4).End(xlUp)) If InStr(r.Value, "(") And rr Is Nothing Then Set rr = r.Resize(3) For j = 1 To 3 v(1, j) = Split(Replace(rr.Item(j).Value, ")", ""), "(")(0) v(1, j + 3) = Split(Replace(rr.Item(j).Value, ")", ""), "(")(1) Next rr.Item(1).Offset(, 1).Resize(, 6).Value = v ReDim v(1 To 1, 1 To 6) With rr.Resize(1).Offset(3) If RegExp.test(.Value) Then For Each match In RegExp.Execute(.Value) rr.Item(1).Offset(, i).Value = match.Value i = i + 1 Next End If End With ElseIf LenB(r.Value) < 1 Then Set rr = Nothing i = 7 End If Next Set RegExp = Nothing Set rr = Nothing Erase v End Sub
- ベストアンサー
- オフィス系ソフト
- 12か月分の日付データを繰返し記入したい
下記動作を実現したくマクロを書いてみましたが、正常に処理できません。 修正が必要な箇所&修正方針について、知識のある方からご助言いただけますと幸いです。。 ＜実現したいこと＞ ・sh2のV列（2行目～）に対し、 2019/4/1 2019/5/1 … 2020/3/1 と12行書き込む処理を、（sh1の２～最終行）回行う ※最終的に、sh2のV列は、先頭行の下に、（sh1の２～最終行）×12行できる想定 ＜正常に動かなかった記述＞ Sub V列の処理() Dim sh1 As Worksheet, sh2 As Worksheet Dim r As Long, i As Long Application.ScreenUpdating = False Set sh1 = Worksheets("元シート") Set sh2 = Worksheets("集計用シート") '２から最終行まで12行おきの繰り返しです For r = 2 To sh1.Cells(Rows.Count, 1).End(xlDown).Row Step 12 'まず、V列の各1行目に4月の値を入れます sh2.Cells(r, 22) = "2019/4/1" 'したら、12か月分入れていきます For i = 1 To 11 sh2.Cells(r + i, 22) = DateAdd("m", i, Cells(r, 22)) Next i Next r Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- VBA 100行ごとに列を変更してコピーする。
Winは7、Excelは2013を使用しています。 A列とB列のデータを100行毎に列を変えてコピーしたいと思っています。 （画像参照願います。） それで、別シートにコピペするサンプルコードを見つけたのですが、 同シート内でする様に変更する知識がなく、苦戦しています。 申し訳ありませんが、ご教示願います。 別シートにコピペするサンプルコード Sub データを100行ごとに分割する() Dim シート As Worksheet, 元 As Worksheet '元は元データのあるシート Dim 総行数 As Long, 回数 As Long, i As Long, 開始行 As Long Const コピー行 = 100 Set 元 = ActiveSheet '変数の元をActiveSheetにセットする 総行数 = 元.UsedRange.Rows.Count 回数 = Int(総行数 / コピー行) + IIf(総行数 Mod コピー行 > 0, 1, 0) 開始行 = 1 For i = 1 To 回数 Set シート = Sheets.Add シート.Name = 開始行 & "～" & 開始行 + コピー行 - 1 元.Rows(開始行 & ":" & 開始行 + コピー行 - 1).Copy シート.Range("A1") Columns("A:F").AutoFit 開始行 = 開始行 + コピー行 Next i End Sub
- ベストアンサー
- Excel（エクセル）
- Dictionaryのitemを効率よく配列に格納
まだエクセル2000です。 A列に商品名（約1,000種類） B列に分類名（10種類） C列に売上高 がある表があります。 （実際はその他の欄もありますが、質問のため単純化しています） 1行1レコードで時系列順に記載されていますので商品名も分類名も重複しています。 （もちろんデータ自体は重複していません。） 行数は不定です。 このデータから、各商品ごとに各分類別の売上高一覧（同一商品名でも分類が違えば別に集計）を作成するため、Dictionaryオブジェクトを利用して以下のマクロを書きました、 Sub test01() Dim myDic As Object Dim myV, myW, myX Dim i As Long, n As Long Dim ws As Worksheet With Sheets("Test01") myV = .Range("A1", .Cells(Rows.Count, "C").End(xlUp)).Value '対象範囲を配列に End With ReDim myW(1 To UBound(myV), 1 To 3) '一覧データ格納用2次元配列サイズ設定 Set myDic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(myV) If Not myDic.Exists(myV(i, 1) & myV(i, 2)) Then '商品+分類が初出なら myDic.Add myV(i, 1) & myV(i, 2), myV(i, 3) 'keyに追加、itemに売上 n = n + 1 'カウント myW(n, 1) = myV(i, 1) '配列に商品名 myW(n, 2) = myV(i, 2) '配列に分類名 Else '商品+分類が既出なら myDic(myV(i, 1) & myV(i, 2)) = myDic(myV(i, 1) & myV(i, 2)) + myV(i, 3) 'itemに売上加算 End If Next i ReDim myX(0 To UBound(myDic.Items)) 'item配列格納用1次元配列サイズ設定 myX = myDic.Items '1次元配列にItem格納 For i = 1 To UBound(myDic.Items) + 1 myW(i, 3) = myX(i - 1) '配列から配列へitemデータ複写 Next i Set ws = Sheets.Add 'シート追加 ws.Range("A1").Resize(UBound(myDic.keys) + 1, 3).Value = myW '配列張り付け Set myDic = Nothing Set ws = Nothing End Sub これで正常かつ高速に作動するのですが、疑問点があります。 itemのデータを2次元配列、myWの3列目に格納するのに、いったん1次元配列myXを経由しなくともよい方法はないのかということです。 ここを変えてみても多分実行速度にほとんど影響はないとは思いますが、何か無駄なことをしているようで気になります。 itemを配列myWにとりこまず、直接ワークシートのC1以下にApplication.Transpose(myDic.items)で張るのが効率的と思いますが、わたしのエクセルがまだ2000のため、Transpose関数の限界、5461個にひっかかるおそれがあり、使えません。 どうかご教示ください。
- ベストアンサー
- その他MS Office製品
- エクセルVBA プルダウンのリスト 指定範囲以外で
こんにちは。 現在、業務で案件の簡単な進捗表を作成しています。 VBAで他の、ご質問/回答を基にマクロを組んで遊んで？いますが、 以下の問題に困っています。 現在作成中のエクセルファイルのステータスですが、 (1)A列に”入力規則”でプルダウン（終了,延期）を設けています。 (2)マクロでA列のプルダウンで”終了”の場合はA:AFまでグレーアウト 同様に”延期”の場合はA:AFまで黄色 (3)マクロでC列に”土”ならフォントを青で日なら赤 やりたい事ですが、 (1)の事を”マクロ”でやりたいんです。 リストで元の値を指定してマクロを組む方法は、 いくらでもネット上に転がっているのですが、 元の値を範囲ではない方法、つまり、 入力規則⇒リスト⇒ ”=$A$1:$A$10” ではなく、”りんご,ばなな、みかん”のように、 マクロのコード内で範囲を構成したい、、、 うまくいえませんが、簡単に言うと、プルダウンメニューが2つしかないのに、 わざわざ、データ用の別シートを作ったりしたくない、、、という理由です。 このプルダウンメニューのマクロを今の下記コードに組み込ませたいのですが、 どなたか、ご教授願います。 ※今後の事も考え拡張性（プルダウンメニューの追加とか）を考慮したものを書きたいです。 マクロが面白くなってきたから勉強しているのであって、 入力規則の今のままでいいのでは？という野暮な回答はご遠慮します。 上記の(2)と(3)を他の質問から見よう見まねで組み合わせ、 動作は確認出来ています。 以下が組み合わせたものとなります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim RngA1 As Range Dim RngA2 As Range Dim RngC1 As Range Dim RngC2 As Range Dim RngE1 As Range Dim RngE2 As Range Dim rr As Range Dim i As Long Dim c As Range Dim myColor As Long Dim clr As Integer '#########################Ａの処理######################### Set RngA1 = Range("A:A") '判定の対象となる列 Set RngA2 = Range("A:AF") '色を変える列 If Intersect(Target, RngA1) Is Nothing Then GoTo SYORI_C For Each c In Intersect(Target, RngA1) With c Select Case .Value Case "終了": myColor = 48 Case "延期": myColor = 27 Case Else myColor = xlColorIndexNone End Select Intersect(c.EntireRow, RngA2).Interior.ColorIndex = myColor End With Next '#########################Cの処理######################### SYORI_C: Set RngC1 = Range("V:V") '判定の対象となる列 Set RngC2 = Range("V:W") '色を変える列 If Intersect(Target, RngC1) Is Nothing Then GoTo SYORI_E For Each c In Intersect(Target, RngC1) With c Select Case .Value Case "無し": myColor = 48 Case Else myColor = xlColorIndexNone End Select Intersect(c.EntireRow, RngC2).Interior.ColorIndex = myColor End With Next '#########################Eの処理######################### SYORI_E: Set RngE1 = Range("X:X") '判定の対象となる列 Set RngE2 = Range("X:Y") '色を変える列 If Intersect(Target, RngE1) Is Nothing Then GoTo SYORI_G For Each c In Intersect(Target, RngE1) With c Select Case .Value Case "無し": myColor = 48 Case Else myColor = xlColorIndexNone End Select Intersect(c.EntireRow, RngE2).Interior.ColorIndex = myColor End With Next '######################################################## SYORI_G: If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub For Each rr In Intersect(Target, Range("C:C")) For i = 1 To Len(rr.Value) Select Case Mid$(rr.Value, i, 1) Case "土": clr = 5 Case "日": clr = 3 Case Else: clr = xlAutomatic End Select rr.Characters(i, 1).Font.ColorIndex = clr Next Next '######################################################## End Sub
- 締切済み
- その他MS Office製品
補足
end-uさん ご回答ありがとうございます。 パターン2が私のやりたかったことです。 問題なく動作しました。 本当にありがとうございます。 Dictionaryを理解できれば、いろいろと応用範囲が 広がると思い、日々動作を検証しています。 ちなみに Set CC = RR.Columns("H:I")を Set CC = RR.Columns("H:J")にし、 ReDim myList(1 To .Count, 3) i = 0 For Each v In .Keys i = i + 1 'キーをvbTabで分割 ary = Split(v, vbTab) myList(i, 0) = ary(0) 'H列の値 myList(i, 1) = ary(1) 'I列の値 myList(i, 2) = ary(2) 'J列の値の合計 myList(i, 3) = .Item(v) 'H,I列値のカウント数 Next '省略 のようにしたい場合、ary(2)を 下記の場合はカウントですが、 For i = 0 To UBound(v) - 1 .Item(v(i)) = .Item(v(i)) + 1 Next 値の集計をさせることはできるのでしょうか？ ここまで動作が理解できれば、試してみたいことが あるので、よろしくお願いします。