• ベストアンサー

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

いつもお世話になっております。 現在dictionary勉強中ですが、なかなかコツをつかめず 思ったとおりのマクロを作成することができません(ノ_;) ところで、今回作成しているのは 元データ.xlsというファイルのシート(データ)に   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】|・・・|【会場名】|(見出し) 4  データの始まり↓ と、ありまして、 集計データ.xlsのシート(集計)に  | A | B | C | D | E | F | 1 顧客ID|担当|会場名| と二行目から一覧表があります。 A列のIDが一致するものに Sheet(データ)  →  Sheet(集計)  セル( i, "D")の値 → セル( j, "B") に セル( i, "J")の値 → セル( j, "C")に     セル(j,"C")に値が入っているとき、セル(j,"D")に→Fまで(4回のみ) A列のIDが一致するものがない時 セル( i, "A")の値 → セル( 最終,"A")に  セル( i, "D")の値 → セル( 最終, "B") に セル( i, "J")の値 → セル( 最終,"C")に追加 というように、入れたいのですが、 以下のようなコードをネットで見つけ自分なりに考えて変更を加えてみましたが あまり分かっていないためどのように変更すればいいのかよく分かりません。どなたかご教授ください。お願いします。 Sub Try() Dim data_1() As String Dim data As Long Dim maxrow As Long Dim t As Integer, f As Integer, y As Integer Set ws1 = Worksheets("集計") Set ws2 = Worksheets("データ") Application.ScreenUpdating = False maxrow = ws2.Range("a65536").End(xlUp).Row With ws1 For i = 2 To Range("a65536").End(xlUp).Row data = .Cells(i, 1) f = 0 t = 0 With ws2 t = Application.WorksheetFunction.CountIf(.Range("a4:a" & maxrow), data) If t > 0 Then For n = 1 To maxrow ReDim Preserve data_1(f) If data = .Cells(n, 1) Then data_1(f) = .Cells(n, 10) f = f + 1 If t = f Then Exit For Else 'A列にIDが存在しなければ追加する:ここの記述がよく分かりません。 data_1(f) = .Cells(n, 1) End If Next n For y = 0 To UBound(data_1) ws1.Cells(i, maxcol(i)) = data_1(y) Next y End If End With Next i End With Application.ScreenUpdating = True End Sub '-------------------------- Private Function maxcol(ByVal i As Long) As Integer Dim j As Integer With Worksheets("集計") j = 4 Do While .Cells(i, j) <> "" j = j + 1 Loop maxcol = j End With End Function

質問者が選んだベストアンサー

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.10

>二回目 >   A | B | C   | D   | E | F | >1 顧客ID|担当 |会場名(1)|会場名(2)| >  2005 |山田 |会場A  |会場B  | >  2006 |田中 |空白   |会場C  | これは、空白セルは詰めないという事ですね。 その場合は以下のように修正が必要です。 Sub try2()   'VBE[ツール][参照設定]で『Microsoft Scripting Runtime』にチェック   Dim ws As Worksheet   Dim dic As Scripting.Dictionary   Dim v  As Variant '集計データ格納用配列   Dim w  As Variant '元データ格納用配列   Dim i  As Long   Dim j  As Long   Dim k  As Long   Dim x  As Long      With Workbooks("元データ.xls").Sheets("データ")     w = .Range("J4", .Cells(.Rows.Count, 1).End(xlUp)).Value   End With      Set ws = Workbooks("集計データ.xls").Sheets("集計")   With ws.Cells(1).CurrentRegion     x = .Rows.Count     k = .Columns.Count + 1     v = .Resize(x + UBound(w), k).Value   End With   v(1, k) = "会場名(" & k - 2 & ")"      Set dic = New Scripting.Dictionary   For i = 1 To x     dic(v(i, 1)) = i   Next      For j = 1 To UBound(w)     If dic.Exists(w(j, 1)) Then       i = dic(w(j, 1))       v(i, k) = w(j, 10)     Else       x = x + 1       dic(w(j, 1)) = x       v(x, 1) = w(j, 1)       v(x, 2) = w(j, 4)       v(x, k) = w(j, 10)     End If   Next      With ws.Cells(1).Resize(x, k)     .ClearContents     .Value = v   End With      Set dic = Nothing   Set ws = Nothing End Sub ※2回目実行前にはD列には何も入力しておかない事、  3回目実行前にはE列には何も入力しておかない事、が条件です。 ついでに事前に[参照設定]する書き方にしてみました。(事前バインディング) そうしておくと、 dic. のあとに[プロパティ/メソッドの一覧]が表示されるVBEインテリセンス(入力支援)が効きますから コーディングが楽になるでしょう。

その他の回答 (13)

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

またまたまた登場、onlyromです。 前回のダブりの例、もうひとつ場合が抜けたました。 (例1: IDと会場名セットでのダブり) 4行目__2005__AA  5行目__2005__AA 6行目__3333__XX (例2: IDのみのダブり ) 4行目__2005__AA  5行目__2005__BB 6行目__3333__XX 何れにしろ、エラーというものは入力時点でチェックされるものあり、 また、今回の目的は「Dictionaryオブジェクトの理解」ですので、 エラーチェックという余計なコードを増やすのは、その妨げになると考えます。 よって、上記、例1、2とも正しいデータとして扱います。   ●テストデータを以下のように作成して実行してください。 (1)元データ.xlsも集計データ.xlsもそれぞれ新しいブックを作成する (2)本データの一部コピーして、データシートを作成する (3)集計データには、(2)で作成したデータの最後のデータのIDは入れないで新規にしておく (4)1回実行したあと、同じデータの最後に、新IDのデータを入れ2回目を実行する このようにすれば上手くいったかどうかの判断がし易いでしょう。 '--------------------------------------------------  Sub Test()  Dim R As Long  Dim Clm As Integer  Dim LastRow As Long  Dim TargetRow As Long  Dim BookPath As String  Dim OldClm As Integer  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    Clm = Cells(R, Columns.Count).End(xlToLeft).Column    If Clm > OldClm Then      OldClm = Clm    End If  Next R  If OldClm < 2 Then OldClm = 2  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       If Clm < OldClm Then         Clm = OldClm       End If       .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, OldClm + 1).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 '------------------------------------------------------- テスト用の集計データ.xls、元データ.xlsはともに同じフォルダーに入れて実行。 それから、end-uさんのDictionaryを使ったもの、No12のDictionaryを使ってないものも、end-uさんのいう条件のもとで試してください。 スキルアップのためにきっと役立つはずです。 以上。  

Rin-u_u
質問者

お礼

いろいろと勉強になりました。 色んなコードを知ることができすごく感謝しています。 ありがとうございました。

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

またまた登場、onlyromです。 >常に会場データはJ列に入っており、 >元データの顧客IDを集計の顧客IDに一致する場所のC以降に >会場データを入れていくというかんじです。 それは最初から理解しておりまする。(^^;;; >(1回目) >2005 は ダブりあり、”AA”、”BB” >”AA”、”BB”と二つ入っていることはありません。 これも理解しています。 当方がダブりと言いましたのは (データシート) 4行目__2005__AA  5行目__2006__CC 6行目__2005__AA このようなものを指しています。 4行目と6行目でID番号2005がダブっていますよね。 こういうことはない、ということですか?   最初の質問で、重複4つと言ったのはこういうことだと解釈しましたが。。。   何れにしろどういうデータであれ動作するコードは仕上げてありますが、 一応、上記の補足があった時点でアップすることにしたいと思います。   >今回のケースは、ディクショナリが勉強できていない上に >ルーチンもちょっと自分にはまだ背伸びしすぎのコードです。 >ホントにありがとうございます。 初めは誰でもそうです。OJTこそがスキルアップのコツです。 頑張る人を応援する、至極当然のことだと考えます。 end-uさんもきっとそうでしょう。 同じことをするにも色んなコードの書き方があります。 色々参考にして頑張りませう。 以上。

Rin-u_u
質問者

補足

ありがとうございます。 4行目__2005__AA  5行目__2006__CC 6行目__2005__AA こういうダブりは基本的には無いはずです。 ただ、件数が多く、使う人も複数ですので 何かの間違いで入ってしまっていることは考えられますが・・・(汗

  • end-u
  • ベストアンサー率79% (496/625)
回答No.12

難解だとは思いますが、Dictionaryオブジェクトを使わない別解法を。 Sub try3()   Dim rd As Range '元データ範囲   Dim rs As Range '集計データ範囲   Dim ra As Range 'データ追加先      Set rs = Workbooks("集計データ.xls").Sheets("集計").Cells(1).CurrentRegion   Set ra = rs.Offset(rs.Rows.Count).Range("A1:B1")   '項目名をコピー。   rs.Range("A1:B1").Copy ra   With Workbooks("元データ.xls").Sheets("データ")     '3行目の項目名も含めて元データ範囲をセット。     Set rd = .Range("J3", .Cells(.Rows.Count, 1).End(xlUp))     With .Range("IV1:IV2")       .Cells(1).Value = "条件"       .Cells(2).Formula = "=ISNA(MATCH(A4," & _                  rs.Columns(1).Address(external:=True) & ",0))"       rd.AdvancedFilter Action:=xlFilterCopy, _                CriteriaRange:=.Cells, _                CopyToRange:=ra       .Clear     End With   End With   '追加した項目名の行を削除   ra.EntireRow.Delete   '集計データ範囲を再セット。   Set rs = rs.CurrentRegion   With rs.Offset(, rs.Columns.Count).Columns(1)     .Value = Application.VLookup(rs.Columns(1), rd, 10, 0)     .Replace "#N/A", ""   End With      Set ra = Nothing   Set rs = Nothing   Set rd = Nothing End Sub ポイントは、 1)存在確認とデータ追加を、計算検索条件によるAdvancedFilterメソッドで一気にやってしまう。  http://support.microsoft.com/kb/402757/ja 2)配列を返すApplication.VLookup関数で、まとめて値をセットする。 ...という感じで、Loopなしのパターンでシンプルに処理してみました。 Sheets("集計")のA1:B1セルの項目名と、Sheets("データ")のA3,D3セルの項目名が一致していれば うまくいくはずです。 #うまくいかなくても、これは蛇足の参考コードなのであまり気にしないでください。 それではこの辺で。がんばってください。

Rin-u_u
質問者

お礼

いろいろと勉強になりました。 色んな種類のコードを書いてくださってお手数おかけいたしました。 とっても感謝しています。 ありがとうございました。

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

あちゃーーー、 >  2006 |田中 |空白   |会場C  end-uさんの回答の最初を見てこれを見落としていたことに気づきました。 申し訳ありませぬ。。(^^;;; で、以下を確認。 ------------------------------------------------- (1回目) 2005 は ダブりあり、”AA”、”BB” 2006 は 空白データ 顧客ID 会1 会2 2005 AA BB 2006 ●● ●● ------------------------------------------------ 2回目 2005 は 空白データ 2006 は ”CC” 3003 は、新規でダブり ”DD”と”EE” 顧客ID 会1 会2 会3 会4 2005 AA BB ●● ●● 2006 ●● ●● CC ●● 3003 ●● ●● DD EE ------------------------------------------------- ダブりがあると上記のようになるので、 見出しの会場名1、会場名2・・・と、 マクロ実行の1回目、2回目・・・は関係ないことになります。 ということは集計シートを一見しても直ぐには マクロ実行の1回目、2回目・・・は分かりませんが それはいいのですね。   もうひとつ。 ほんとうにダブりはあるのでしょうか。 補足などではダブりはないように思えますが。 ダブりがなければ、前回処理で会社名がどの列まで入ったかを検索するのが簡単になります。 上記のようにダブりがあるということなら、コードが数行増えます。 が、▲▲何らの条件にも拘束されません。▲▲ (余談) end_uさんも仰ってますが、質問の件は、Dictionaryオブジェクトを勉強するにはちょっと。。です。 なぜならDictionaryよりも他のルーチンが質問者にはややこしいのではと思われます。 Dictionaryを勉強するにはも少しシンプルなデータを用いて習得すべきだと考えます。 以上。

Rin-u_u
質問者

補足

何度も気にかけていただいてすみません。 常に会場データはJ列に入っており、 元データの顧客ID を集計の顧客IDに一致する場所のC以降に 会場データを入れていくというかんじです。 説明が下手です。すみません。 (1回目) 2005 は ダブりあり、”AA”、”BB” ↑”AA”、”BB”と二つ入っていることはありません。 2006 は 空白データ (1回目) 顧客ID 会1  2005 AA  2006 ●●  ------------------------------------------------ 2回目 2005 は 空白データ 2006 は ”CC” 3003 は、新規”DD” 顧客ID 会1 会2 会3 会4 2005 AA ●● 2006 ●● CC  3003 ●● DD  ------------------------------------------------- 今回のケースは、ディクショナリが勉強できていない上に ルーチンもちょっと自分にはまだ 背伸びしすぎのコードです。 ホントにありがとうございます。

  • 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
質問者

お礼

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

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

質問、補足など読んでいくといくつか重要な点が抜けてます。 それらを補足してください。 さすれば質問者のレベルに合わせたDictionaryオブジェクトをアップすることに吝かではありませぬ。   (1)コードは、元データ.xls、集計データ.xlsのどちらに書いてあるのか (2)元データ.xls、集計データ.xlsは予め両方とも開いているか (3)集計データ.xlsの転記されるエリアはマクロ実行の最初でクリアーしなくていいのか (4)重複4つと書いてあるが実際は重複とは関係なくこのマクロが実行されるたびに、列方向へ転記するのではないのか   これはどういうことかと言うと、   ID番号2005があり、今月のデータから転記され   次回の処理(来月のデータ)でまた、2005が発生していた場合など。 (3)と(4)は関係あり 以上。  

Rin-u_u
質問者

補足

ありがとうございます。 まず、 (1)コードは集計データに書きます。 (2)この部分は今まだ作成中なのですが、 Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Dim objFSO Dim objFOL Dim objWK Set mb = ThisWorkbook 'このブック(集計)をmbとする Set objFSO = CreateObject("Scripting.FileSystemObject") myfdr = ThisWorkbook.Path Set objFOL = objFSO.GetFolder(myfdr) For Each objWK In objFOL.SubFolders という風に、サブフォルダーの中から「元データファイル」を 探してきて、 For Each f In objWK.Files If fso.GetExtensionName(f.Path) = "xls" And f.Name = "元データ.xls" Then With Workbooks.Open(f.Path) というようにオープンメソッドを使う予定にしております。 (3)集計データはクリアしません。 追加の顧客IDが存在するかどうか調べて追加する&既存の顧客IDには増えた【会場名】データ(J列)のみを追加するためです。 (4)元データ 一回目   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】| ・・・ |【会場名】|(見出し) 4  2005 |  ・・・・山田|  ・・・・会場A|   2006 |  ・・・・・田中|  ・・・・空白| 二回目   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】|・・・|【会場名】|(見出し) 4  2005 | ・・・・山田| ・・・・会場B|←書き換えデータ    2006 ・・・・・|田中| ・・・・会場C|←書き換えデータ のとき、 集計データは 一回目 | A | B | C | D | E | F | 1 顧客ID|担当|会場名|  2005 |山田|会場A|  2006 |田中|空白| 二回目 | A | B | C | D | E | F | 1 顧客ID|担当|会場名(1)|会場名(2)  2005 |山田|会場A|会場B|  2006 |田中|空白 |会場C とする予定です。

  • end-u
  • ベストアンサー率79% (496/625)
回答No.7

Sub try()   Dim ws As Worksheet   Dim dic As Object   Dim v  As Variant '集計データ格納用配列   Dim w  As Variant '元データ格納用配列   Dim i  As Long   Dim j  As Long   Dim k  As Long   Dim x  As Long      Set ws = Workbooks("集計データ.xls").Sheets("集計")   '追加考慮し大きめに配列取る。   v = ws.Range("A1:F65536").Value   '最終データ行を取得しておく。   x = ws.Range("A65536").End(xlUp).Row      With Workbooks("元データ.xls").Sheets("データ")     w = .Range("J4", .Cells(.Rows.Count, 1).End(xlUp)).Value   End With   'Dictionaryオブジェクトに既集計キーを読み込む。同時にItemに行を記憶。   Set dic = CreateObject("scripting.dictionary")   For i = 1 To x     dic(v(i, 1)) = i   Next      For j = 1 To UBound(w)     'Existsメソッドで存在確認。それにより分岐。     If dic.exists(w(j, 1)) Then       i = dic(w(j, 1))       For k = 4 To 6         If IsEmpty(v(i, k)) Then           v(i, k) = w(j, 10)           Exit For         End If       Next     Else       x = x + 1       dic(w(j, 1)) = x       v(x, 1) = w(j, 1)       v(x, 2) = w(j, 4)       v(x, 3) = w(j, 10)     End If   Next      With ws.Cells(1).Resize(x, 6)     .ClearContents     .Value = v   End With      Set dic = Nothing   Set ws = Nothing End Sub Dictionaryオブジェクトはプロパティやメソッドがシンプルで、使い勝手が良く、 特にExistsメソッドは高速に処理できますから便利ですね。 私も好きです。 ただ今回のケースは『勉強』に適した題材かというと、ちょっと厳しいかもしれませんね。 基本についても押さえておかれたほうが良いと思います。 http://msdn.microsoft.com/ja-jp/library/cc428065.aspx http://www.geocities.jp/cbc_vbnet/Scripting/dictionary.html

Rin-u_u
質問者

お礼

ありがとうございます。私もはやくディクショナリーを使いこなせるようになりたいです。。。 本当にすごくスマートで素敵なコードに感動しています!! 更に、基本がわかるサイトまでご紹介いただいてご丁寧な対応に本当に感謝しています。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.6

>追加変更が目的で追加というところで悩んでます。 であればANo.4での回答の通り、Findで見つからない場合の 処理でいいのでは? 私がDictionaryを回答したのは、ANo.5に記載した通りの事だと 思っていましたので。 >Dictionary勉強中なのでそのあたりを出来れば教えていただきたいのですが… 正直私も解説できるほど理解はしてないです。 他の方の回答されたコードを自分で試してみて、の手探り状態で勉強 していましたので。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.5

>元データ.xlsというファイルのシート(データ)に >集計データ.xlsのシート(集計)に よくよく読むとBookが違ったのですね。 集計シートには既にデータがあり、追加・変更が目的なのか、 データシートのデータ追加・変更等で、その都度集計シートを白紙にして、 全て書き換えてしまっていいのか、 で違ってきますね。 私はてっきり後者だとばかり思っていたものですから、 見当違いのアドバイスだったかも? imogasiさんへ >dictionaryはVBSや.NETの概念ではないですか。エクセルVBA独自でそんな機能ありましたっけ。 私もVBSの機能だと思いますよ。 ExcelVBAの参考書では余り書いてないように見受けられ、VBScriptの参考書を 見ながら勉強してますし。

Rin-u_u
質問者

補足

追加変更が目的で追加というところで悩んでます。 Dictionary勉強中なのでそのあたりを出来れば教えていただきたいのですが… ケータイからの投稿ですのでちゃんと書きたいことがすべて書けていません すみません

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.4

>dictionary勉強中ですが・ dictionaryはVBSや.NETの概念ではないですか。エクセルVBA独自でそんな機能ありましたっけ。私の不勉強ならすみません。 何で難しい概念・仕組みで解決する必要があるのかな。 ーー この質問をざっと見て、Findメソッドで「顧客ID」を同じものを他ファイル「集計データ」側で見つけ、そこにデータまたは「顧客ID」で集計済みデータを代入したらよいようなんだが。 こんなに長いコードにならないのではないですか。 見つからなければ最終行以下に追加。 ーー 両ファイルのレコードの並び順と重複出現の点は書いて置いてください。 集計データの顧客ID他は(前月作業とかで)暫定的に中身が出来上がっているのですか。 ーー 読者のことも考えて、読者に長いコードを解読させるコード実例は困る。今後は要点を文章で添えるとかポイントを絞る質問をお願いします。

Rin-u_u
質問者

補足

Findですね。ありがとうございます。調べます。

関連する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" となってしまいます。 どこに原因があるのかわかりません。 助けてください。 宜しくお願いします。

専門家に質問してみよう