• ベストアンサー

VBA【dictionary勉強中ですが・・・】集計マクロ

onlyromの回答

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.9

再度の登場、onlyromです。 '-------------------------------------------------  Sub Test()  Dim R As Long  Dim Clm As Integer  Dim LastRow As Long  Dim TargetRow As Long  Dim BookPath As String  Dim myDic  Set myDic = CreateObject("Scripting.Dictionary")  Sheets("集計").Select  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row    If myDic.Exists(Cells(R, "A").Value) = False Then      myDic.Add Cells(R, "A").Value, R    End If  Next R  BookPath = ThisWorkbook.Path  Workbooks.Open BookPath & "\元データ.xls"  With ThisWorkbook.Sheets("集計")   For R = 4 To Cells(Rows.Count, "A").End(xlUp).Row     If myDic.Exists(Cells(R, "A").Value) Then       TargetRow = myDic.Item(Cells(R, "A").Value)       .Cells(TargetRow, "B").Value = Cells(R, "D").Value       Clm = .Cells(TargetRow, Columns.Count).End(xlToLeft).Column       .Cells(TargetRow, Clm + 1).Value = Cells(R, "J").Value     Else       LastRow = .Cells(Rows.Count, "A").End(xlUp).Row       .Cells(LastRow + 1, "A").Value = Cells(R, "A").Value       .Cells(LastRow + 1, "B").Value = Cells(R, "D").Value       .Cells(LastRow + 1, "C").Value = Cells(R, "J").Value       myDic.Add Cells(R, "A").Value, LastRow + 1  '●重要     End If   Next R  End With  Workbooks("元データ.xls").Close False End Sub '-----------------------------------------------------  ●重要 、について 集計シートにないIDは、集計シートの最後に追加するのですが、 さらに、そのIDが重複もしてる場合も想定しているため。   尚、上記コードはわざとオブジェクト変数は使ってありませんが 実際は、Select,Activateメソッドなど使用しないように オブジェクト変数を使う方がベターでしょう。 それから、元データ.xlsはThisworkbookのPathから開いています。   以上。

Rin-u_u
質問者

お礼

ありがとうございます。 非常にわかりやすく わたしのレベルに合わせてくださっているということが すごくよくわかります。 本当に感謝いたします。

関連するQ&A

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • VBA データの統合機能

    Winは7、Excelは2013を使用しています。 以前、データの統合機能というのをこちらで教わり、 その構文を使用させて頂いているのですが、 下記の、方法を集計のところの、Rnage("A7")のところに、変数 rnを使用したいのですが、 エラーコード438が出てしまいます。 あと、年間集計のところにデータを書きだすところで、画像の青枠の様に1列おきに書き出したいのですが、可能でしょうか? 以上、2点ご教示頂けますようお願い致します。 Sub test_データの統合機能() Dim sArray() As String ReDim sArray(Sheets.Count - 2) As String Sheets("年間集計").Select Cells.ClearContents '-------------------------------------------- '科目年間集計 '-------------------------------------------- For i = 2 To Sheets.Count sShtName = Sheets(i).Name sShtAddress = Sheets(i).Range("M2").CurrentRegion.Address(, , xlR1C1) sArray(i - 2) = sShtName & "!" & sShtAddress Next i Sheets(1).Range("A1").Consolidate Sources:=sArray, _ Function:=xlSum, _ TopRow:=True, _ LeftColumn:=True, _ CreateLinks:=False '-------------------------------------------- '合計 '-------------------------------------------- Dim maxCol As Long Dim maxRow As Long Dim c As Integer Dim r As Integer maxCol = Range("A2").End(xlToRight).Column maxRow = Range("A2").End(xlDown).Row Cells(1, maxCol + 1) = "合計回数" Cells(1, maxCol + 2) = "合計時間" For r = 2 To maxRow For c = 2 To maxCol Step 2 Cells(r, maxCol + 1) = Cells(r, maxCol + 1) + Cells(r, c) Cells(r, maxCol + 2) = Cells(r, maxCol + 2) + Cells(r, c + 1) Next c Next r '-------------------------------------------- '方法を年間集計 '-------------------------------------------- Dim rn As Range Set rn = Cells(maxRow + 2, 1) For i = 2 To Sheets.Count sShtName = Sheets(i).Name sShtAddress = Sheets(i).Range("Q2").CurrentRegion.Address(, , xlR1C1) sArray(i - 2) = sShtName & "!" & sShtAddress Next i Sheets(1).Range("A7").Consolidate Sources:=sArray, _ Function:=xlSum, _ TopRow:=True, _ LeftColumn:=True, _ CreateLinks:=False '-------------------------------------------- 'このあとに合計を計算する '-------------------------------------------- '(略) End Sub

  • ExcelVBA一致しない場合その他の行に集計する

    「ExcelVBA複数条件一致後別シートに結果表示」という質問を以前させていただき、丁寧にコードを解説していただきました。 ※その節はありがとうございました。 ●ファイルの内容(概要)配下の通りの構成です。  <Sheet1>   A列:性別(男性:1、女性:2でコード化)   B列:死因コード(数値5~6桁)   C列:年齢   D列:市町村(3桁でコード化「201」等)  <Sheet2>Sheet1で条件に一致したものを以下の通り表を作成する   ・「セルA1」に表にしたい市町村コードをあらかじめ入力しておく   ・セルB1~セルEC1まで死因コード   ・セルA2~セルA132まで年齢0~130   ・セル範囲B2~EC132に「A1」に入力した市町村コードの男性の値が入る   ・セルB133~セルEC133まで死因コード   ・セルA134~A264まで年齢0~130   ・セル範囲B134~EC264に「A1」に入力した市町村コードの女性の値が入る そして、以下のコードを教えていただきました。 **************************************************** Dim r As Long Dim i As Integer, j As Integer, k As Integer Dim Wsf As Object Dim SCode As Range, Nenrei As Range Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("sheet1") Set Ws2 = Worksheets("sheet2") Set Wsf = Application.WorksheetFunction Application.ScreenUpdating = False Ws2.Range(Ws2.Cells(2, 2), Ws2.Cells(132, 133)).ClearContents Ws2.Range(Ws2.Cells(134, 2), Ws2.Cells(264, 133)).ClearContents With Ws2 Set SCode = .Range(.Cells(1, 1), .Cells(1, 133))  ↑ここはこのように書いていただいたのから、  指定の死因分類があったためシートから参照するようコードを変えています。  手元にファイルが無くてかけないのが初心者の情けないところです。  申し訳ありません。※シートは同一ファイル内におくようにしています。 End With r = 2 Do While Ws1.Cells(r, 1).Value <> "" If Ws1.Cells(r, 4).Value = Ws2.Cells(1, 1).Value Then If Ws1.Cells(r, 1).Value = 1 Then i = 1 ElseIf Ws1.Cells(r, 1).Value = 2 Then i = 134 End If With Ws2 Set Nenrei = .Range(.Cells(i, 1), .Cells(i + 130, 1)) End With j = i + Wsf.Match(Ws1.Cells(r, 3).Value, Nenrei, 0) - 1 k = Wsf.Match(Ws1.Cells(r, 2).Value, SCode, 0) Ws2.Cells(j, k).Value = Ws2.Cells(j, k).Value + 1 Else End If r = r + 1 Loop Application.ScreenUpdating = True Set Scode = Nothing Set Nenrei = Nothing Set Wsf = Nothing Set Ws1 = Nothing Set Ws2 = Nothing End Sub **************************************************** 表はあらかじめ作成しておくので、そこに集計結果が入ります。 実行していたら、古いファイルに不詳の死因コードが登場し、 どうしたらいいかと考えた結果、死因コードの列の最後に「その他」を設け、 死因コードに一致しない場合にはそこに集計結果をカウントすることは できないか?という考えに至りました。 自分で考えるのが一番勉強になると分かっていても試行錯誤している時間が無く、 急ぎのためお知恵のある方々にご協力を頂ければと思い、 再度質問させていただいた次第です。 前の質問は↓こちらです。 http://okwave.jp/qa/q8356291.html 何卒よろしくお願い申し上げます。

  • dictionaryでの集計

    A------B--------【F】---【G】----(H)-----I------(J)---------(O) 1 名前  住所・・・金額  個数  種別(1)  数値  種別(2)・・・・種別(3) 2 3 4~~~~データ始まり~~~~ 5 6 上図のようなデータがあり、種別(1)・(2)・(3)をKeyにして dictionaryで、F列とG列の合計値を求めたいのですが、 エラーばかりでうまくいきません。 インデックスが有効範囲にありません というエラーがちょこちょこ起こります。 Option Explicit Sub syukei() Dim dic As Object, i As Long, j As Long, n As Integer, data As String, tbl, x Set dic = CreateObject("scripting.dictionary") Application.ScreenUpdating = False With Sheets("Sheet1") tbl = .Range("a4").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 15) ReDim x(1 To UBound(tbl, 1), 1 To 15) For i = 1 To UBound(tbl, 1) If Not IsEmpty(tbl(i, 8)) Then data = tbl(i, 8) & "," & tbl(i, 15) If Not dic.exists(data) Then j = j + 1 For n = 1 To 15 x(j, n) = tbl(i, n) Next n dic(data) = j Else x(dic(data), 6) = x(dic(data), 6) + tbl(i, 6) x(dic(data), 7) = x(dic(data), 7) + tbl(i, 7) End If End If Next i .Range("D134").Resize(, 5) = Split("種別 区分 金額合計 個数合計") .Range("D135").Resize(j, 5) = x End With Set dic = Nothing Application.ScreenUpdating = True End Sub このようなコードを書きましたが data = tbl(i, 8) & "," & tbl(i, 15) のところで、型が一致しませんというエラーになります。 .Range("D134").Resize(, 5)に貼り付けようとしています。 種別(2)をkeyに設定するコードを書いていないのは、 種別(2)は、A・B・C・Xとあり、keyごとで分けるのではなく Xか、それ以外かに分けたいので悩んでいます。 いつも頼ってばっかりで申し訳ありませんが、教えてください。 お願いします。

  • マクロdictionaryオブジェクト書き換え

    ここで教えていただいたマクロを   シート1のF列を検索値として   シート2のA列を検索しヒットしたら   シート2の該当行のD列をシート1のAE列に転記。   データの2列目から行う。ヒットしない場合は 無 と転記。 と変更したくて記述を書き換えたらシート1が壊れてしまいました。 正しい記述を教えてください。 ↓教えていただいた書き換え前の正常動作する記述↓ Sub 検索() 'dictionaryオブジェクトを使用 'シート1のA列を検索値として 'シート2のA列を検索しヒットしたら 'シート2の該当行のE列をシート1のC列に転記 'データの2行目から行う。ヒットしない場合は無しと転記 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のF列を検索値として 'シート2のA列を検索しヒットしたら 'シート2の該当行のD列をシート1のAE列に転記 'データの2行目から行う。ヒットしない場合は無しと転記 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

  • マクロが動作しない

    Office2003にバージョンアップすると動作しないマクロが出ました。ちゃんと動作するものもあります。 内容は変更していないので内容はあってるはずですが 念のためコピーします。 Sub 電装品() Dim Gyou As Integer Dim Gyouz As Integer Dim State As Integer Dim Statez As Integer Dim CelValue As String Dim CelValuez As String Dim CopyCelNo As String Dim CopyCelNoz As String Dim WS1 As Object Dim WS2 As Object Set WS1 = Worksheets("購入品リスト") Set WS2 = Worksheets("電装品リスト") WS2.Range("A:G").Delete Shift:=xlToLeft WS2.Range("B1") = "電 装 品 リ ス ト" With WS2.Range("B1") .Font.Bold = True .Font.Italic = True .Font.Size = 24 End With WS2.Range("D1") = "作成日:" & Date WS1.Range("C3:E3").Copy (WS2.Range("A2:C2")) State = 3 For Gyou = 1 To 2000 CopyCelNo = "A" & State CelValue = WS1.Cells(Gyou, 17).Value If CelValue = "1" Then WS1.Range(WS1.Cells(Gyou, 3), WS1.Cells(Gyou, 5)).Copy (WS2.Range (CopyCelNo)) State = State + 1 End If Next WS1.Range("G3:J3").Copy (WS2.Range("D2:G2")) Statez = 3 For Gyouz = 1 To 2000 CopyCelNoz = "D" & Statez CelValuez = WS1.Cells(Gyouz, 18).Value If CelValuez = "1" Then WS1.Range(WS1.Cells(Gyouz, 7), WS1.Cells(Gyouz, 10)).Copy (WS2.Range (CopyCelNoz)) Statez = Statez + 1 End If Next End Sub

  • (VBA)Splitの抜き出しが上手くいかない

    以下のようなコードで「指定区切り文字」の前後で文字列を切り出しています。 添付画像見てもらえれば判ると思いますが B8セルからのB列の値が「29:08」が正解なのに 「29:08:00」と最後に「:00」が付いた形式になっています。 (B13で1時間を過ぎると正常になっています。) このため、以後のE及びF列の書き出しもおかしな値となりました。 どのように修正すれば良いでしょうか ? Option Explicit Sub Chapter_Plus() Dim I As Long Dim J As Long Dim TEMP As Variant Dim SepChr As String Dim WS1 As Worksheet Dim WS2 As Worksheet Dim EndLow As Long Dim LineData As String Dim OutText As String Dim byteData() As Byte '一時格納用 Set WS1 = Worksheets("DATA") Set WS2 = Worksheets("Chapter") 'シートの初期化 WS1.Range("B3:H100").Clear WS2.Range("A1:A100").Clear SepChr = InputBox("指定文字を入力してください。", "区切り文字入力", " ") 'TotalLength = InputBox("時間を(h:mm:ss)で入力してください。", "ファイルサイズ入力") EndLow = WS1.Cells(Rows.Count, "A").End(xlUp).Row With WS1 '区切り文字で切り出す For I = 3 To EndLow TEMP = Split(.Cells(I, "A"), SepChr) .Cells(I, "B") = TEMP(0) .Cells(I, "C") = TEMP(1) Next '仮チャプター書き出す For I = 3 To EndLow .Cells(I, "E").Value = Format(.Cells(I, "B").Value, "hh:mm:ss") .Cells(I, "F").Value = Format(.Cells(I + 1, "B").Value, "hh:mm:ss") .Cells(I, "G").Value = .Cells(I, "C").Value Next '番号 For I = 3 To EndLow .Cells(I, "H").Value = CStr(Format(I - 2, "'00")) Next End With End SUB

  • エクセル2007のVBAでオートフィルタのチェック

    エクセル2007のVBAでオートフィルタのチェックを閾値以上の%のみに入れたいのです。  ユーザー設定フィルタでは視覚的に解りつらい為、フィルタの▽をクリックした時に、チェックがされている事を確認したいのです。 【シート1の内容】 セルA1から行方向に数字の1~3 セルB1から行方向に、値1、値2、% セルA3~Bnは列方向に、整数 セルC3から列方向に、“=A3/B3”が入力されており、書式は パーセンテージ(小数点以下の桁数は“1”) セルD1に 閾値として 10.5%・・・書式はC3に同じ 【目的】 動きとしては、閾値以上の結果を出すつもりで書きました。 【質問】 フィルタがかかった▽をクリックした時に、1行、2行及びC列の10.5%以上のチェックボックスにチェックを入れたいのです。 しかし、下記コードの .AutoFilter Field:=3, Criteria1:=Array("%") _ , Operator:=xlFilterValues, Criteria2:=Array(TargetCD) でエラーが出てしまいます。 実行時エラー '1004': Range クラスの AutoFilter メソッドが失敗しました。 Sub Threshol() Dim MaxRow As Integer Dim TargetCD Dim CDDiff As Integer Dim MinCD As Single Dim MaxCD As Single Dim i As Integer Dim j As Single MaxRow = Range("C1").End(xlDown).Row With ActiveSheet.Range(Cells(3, 3), Cells(MaxRow, 3)) MinCD = ThisWorkbook.Worksheets(1).Range("D1").Value * 100 MaxCD = Application.Round(Application.Max(.Cells) * 100, 1) CDDiff = (MaxCD - MinCD) * 10 ReDim TargetCD(1 To CDDiff + 1) For i = 1 To UBound(TargetCD) TargetCD(i) = FormatPercent(MinCD / 100 + j, 1) j = Format(j + 0.001, "#.###") Next .AutoFilter Field:=3, Criteria1:=Array("%") _ , Operator:=xlFilterValues, Criteria2:=Array(TargetCD) End With End Sub 皆様、良いご助言を宜しくお願い致します。

  • EXCELのVBAについて教えてください。

    演習1というシートの(1,1)のセルの値と(1,2)のセルの値を入れ替えるプログラムを作成したいので すがエラーが出て出来ません。コードは下記の様に書きました。 Sub 演習1() Dim sheetobj As Worksheet Dim a As Integer Set sheetobj = ThisWorkbook.Worksheets("演習1") With sheetobj a = .Cells(1, 1) .Cells(1, 1) = .Cells(1, 2) .Cells(1, 2) = a End With End Sub プログラミング自体が本を読んでも分かりません。 宜しければ小学生に教えるように文を訳してくれませんか?

  • エクセル2003でのマクロで質問です。

    エクセル2003でのマクロで質問です。 セル(2,22)には"1"という値が入っています。 セル(2,13)には"20100521"という値が入っています。 セル(3,13)には"20100521"という値が入っています。 セル(4.13)には"20100525"という値が入っています。 セル(5,13)には"20100525"という値が入っています。 このようなときに セル(3,22)の値は"1" セル(4,22)の値は"2" セル(5,22)の値は"2" となるように以下のようなマクロを作成しました。 Dim i As Integer, j As Integer, date1 As String i = 2 j = 3 Do While Cells(i, 1).Value <> "" If Cells(i, 13) = Cells(j, 13) Then Cells(j, 22) = Cells(i, 22) Else Cells(j, 22) = Cells(i, 22) + 1 End If i = i + 1 j = j + 1 Loop しかし、結果は セル(3,22)の値は"2" セル(4,22)の値は"3" セル(5,22)の値は"4" となってしまいます。 どこに原因があるのかわかりません。 助けてください。 宜しくお願いします。