• 締切済み

エクセルVBA

エクセル2003です 勉強中です 教えてください Sheet1     A      B      C       D      1   日付    種類    数量1    数量2  2   2月3日    C      300        10   3   2月4日     B      200       5 4   2月5日     A     100       20 5   2月3日     A     100       10 6   2月4日     B     200       5 7   2月5日     C     300       20 8   2月3日      A      300       20 9   2月4日     C      200        5 10  2月5日     B     100       10 Sheet1     F      G      H       I      1   日付    種類    数量1    数量2  2   2月3日    A      400          3   2月3日     C      300       4   2月4日     B     600       5   2月5日     A     100       6   2月5日     C     400       7 したい事 *A列~D列のデータをF列からI列へ複数条件の集計をしたいのですが *A列~D列の数値が変動すると勝手に自動で集計をして欲しい(シートがアクティブでなくても) *下記コードでC列までの集計ができますがD列の集計がわかりません  (増やそうとすると頭の中がぐちゃぐちゃになって・・・) *前回の集計が残ってしまう Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3 Dim i As Long Range("F2", Range("I" & Rows.Count).End(xlUp)).ClearContents Range("F1:I1").Value = Range("A1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") ' データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value ' myDicへデータを格納 For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) If Not myVal2 = "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next 'Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") Cells(i + 2, 6).Value = myVal3(0) Cells(i + 2, 7).Value = myVal3(1) Cells(i + 2, 8).Value = myItem(i) Next Set myDic = Nothing '並べ替え Range("F2", Range("H" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("F2"), Order1:=xlAscending, _ Key2:=Range("G2"), Order2:=xlAscending, _ Header:=xlGuess End Sub 頭のなかがこんがらがってしまいます お願いです 出来れば説明付きで教えていただけませんか よろしくお願いします

みんなの回答

  • chie65535
  • ベストアンサー率43% (8522/19371)
回答No.1

1. 作ったマクロは要らないので全部消す 2. H2セルに =SUMPRODUCT(($A$2:$A$10=$F2)*($B$2:$B$10=$G2)*(C$2:C$10)) と言う式を書く。 3. H2セルをI2セルにコピーする。 4. H2、I2セルを選択して、下方向にコピーして、H3~I6に貼り付ける。 すると、以下のようになって、集計が行われる。     F     G    H     I      1   日付   種類  数量1  数量2  2   2月3日  A    400   30 3   2月3日  C    300   10 4   2月4日  B    400   10 5   2月4日  C    200   5 6   2月5日  A    100   20 7   2月5日  B    100   10 8   2月5日  C    300   20

KICHIMAROBON
質問者

お礼

ありがとうございます マクロと組み合わせてかんがえます

関連するQ&A

  • 途中まで出来ているのですが‥(Dicへの複数item追加?)

       A   B   C   D   E    ←シート元 1 大区分 中区分 金額1 金額2 小区分  ←見出し行です。 2  A社 管理課 12000  3000  1 3  B社 総務課 10000  2000  1 4  C社 業務課  800 1000    3 5  A社 総務課           5 6  C社 製造課  600 5000    2 7  A社 製造課 15000        1 8  A社 管理課  300       1 9  B社 管理課  800 2000     4 10  D社 総務課 90000 9000     1 を大区分 中区分 小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが(下記のように 金額1 金額2ごとに足し算)    A   B   C   D   E    ←シート集計 1 大区分 中区分 小区分金額1 金額2   ←見出し位置変更 2  A社 管理課  1 12000 3300 3  A社 総務課  5   4  A社 製造課  1 15000   5  B社 総務課  1 10000 2000 6  B社 管理課  4 8000 2000 以下省略 実際に作りたいものは、元シートの金額の項目が多いのです(列が飛び飛びに40位あります)今回の例でいえばCとDが CからF HからV ABからCHとなりそれぞれ金額3,4,5~50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。 Sub 3keyと2要素() ’実際は40要素くらいある Dim OLDBOOK As Workbook Dim SH1 As Worksheet Dim SH2 As Worksheet Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3, myVal4, myVal5 Dim i As Long Set OLDBOOK = ThisWorkbook Set SH1 = OLDBOOK.Worksheets("元") Set SH2 = OLDBOOK.Worksheets("集計") SH2.Cells.ClearContents SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value SH2.Range("C1").Value = SH1.Range("E1").Value SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") SH1.Select myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next myKey = myDic.keys ' 書き出し とりあえず2要素   myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 1).Value = myVal3(0) SH2.Cells(i + 2, 2).Value = myVal3(1) SH2.Cells(i + 2, 3).Value = myVal3(2) SH2.Cells(i + 2, 4).Value = myItem(i) Next Set myDic = Nothing '******** Set myDic = CreateObject("Scripting.Dictionary") myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 4) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 4) End If End If Next myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing ' 以下繰り返しするしかなく困ってます SH2.Select SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("AF2"), Order1:=xlAscending, _ Key2:=Range("B"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlGuess Set OLDBOOK = Nothing Set SH1 = Nothing Set SH2 = Nothing End Sub

  • エクセル計算式、VBAについて

    エクセル計算式、VBAについて 下記質問の続きでございます。 http://okwave.jp/qa/q5871637.html 先日の質問にて表もうまく完成したかに見えたのですが、 何度か動作確認のテストをしているうちに、少しおかしな点が出てきました。 下記のURLにある表を見ていただきたいのですが、 加工前の状態から、下記のVBAを実行して、別シートへ加工後の形に出力しました。 ※質問文に直接画像を貼りたかったのですが、どういうわけか出来なかったので、 画像URLでのご説明になることをお許し下さい。 ※「加工前」 http://f58.aaa.livedoor.jp/~works/4.jpg ※VBAの内容 Sub ボタン1_Click() With Sheets("加工後") .Range("2:65536").ClearContents For i = 2 To Range("A65536").End(xlUp).Row For j = 1 To Range("D" & i).Value GYOU = .Range("A65536").End(xlUp).Row + 1 .Range("A" & GYOU).Value = Range("A" & i).Value .Range("B" & GYOU).Value = Range("B" & i).Value .Range("C" & GYOU).Value = Range("C" & i).Value .Range("D" & GYOU).Value = Range("D" & i).Value .Range("E" & GYOU).Value = j .Range("F" & GYOU).Value = "111-1111-" & Right("1111" & (i - 1), 4) .Range("G" & GYOU).Value = GYOU - 1 .Range("H" & GYOU).FormulaR1C1 = _ "=MIN(RC[-5],RC[-6]-SUMIF(R1C[-2]:R[-1]C[-2],RC[-2],R1C[-5]:R[-1]C[-5]))" Next j Next i End With End Sub ※「加工後」 http://f58.aaa.livedoor.jp/~works/1.jpg 加工後の結果でおかしいのが、「箱内数量」です。 目立つようにピンクと黄色で色分けしました。 H9とH10 は箱内数量が正しい数値ですが、 H18とH19は本来、H18=50、H19=40 とならなければなりません。 さらに、H22:H24も、H22=50、H23=50、H24=20 となってほしいのです。 ”加工前” シートのH列には下記の計算式が入っており、H列下方へ相対参照にて計算式をコピーしています。 =MIN(INDEX(C:C,MATCH(F2,F:F,0)),INDEX(B:B,MATCH(F2,F:F,0))-(ROW()-MATCH(F2,F:F,0))*INDEX(C:C,MATCH(F2,F:F,0))) ”加工後” シートのH列には事前には何も計算式が入ってませんが、VBAを実行することにより、下記の計算式が入り、H列下方へ相対参照にて計算式がコピーされています。 =MIN(C2,B2-SUMIF(F$1:F1,F2,C$1:C1)) なぜうまく結果が出るところと、出ないところがあるのか分かりません。 正常な結果を求めるには、どこを修正すればよろしいでしょうか?

  • 【Excel】【VBA】重複しないリスト作成について

    「データ」というシートのJ列データを元に、重複しないリストを 作成したいのですが、「データ」にレコードが1件しかないと > For Each c In varData で「型が一致しません」というエラーになってしまいます。 2件以上あると問題なく処理ができるのですが、1件のときに うまく回避させる方法はありますでしょうか。 'データシートのキーワードを重複しないリスト化してA列にコピー Dim sh2 As Worksheet Dim myDic As Object, myKey As Variant Dim c As Variant, varData As Variant Set sh2 = ThisWorkbook.Worksheets("Sheet1") Set myDic = CreateObject("Scripting.Dictionary") With ThisWorkbook.Worksheets("データ") varData = .Range("J3", .Range("J" & Rows.Count).End(xlUp)).Value End With For Each c In varData If Not c = Empty Then If Not myDic.Exists(c) Then myDic.Add c, Null End If End If Next myKey = myDic.Keys '出力 With sh2 .Range("A:A").ClearContents .Range("A4").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey) End With Set myDic = Nothing よろしくお願いいたします。

  • VBA DictionaryオブジェクトのItemについての質問です。

    エクセル2000です。 A列からE列までの1行から最終行不特定の表があります。 A列はすべて文字列で、B~Gは数値、E列は文字列です。 A列の文字列には重複があります。 この表を別シートにA列の重複がない表として作成したいと思います。 その際、列が重複する場合にはB~G列は合計数値、E列は文字列を結合させます。 Dictionaryオブジェクトを用い、A列データをKey、B~E列データを配列でItemとして下記のコードを書きました。 このコードで目的は達成しました。 質問はKeyが重複する場合、B~E列のデータを配列として取り込んだItemに次のB~E列のデータを加算あるいは結合する方法の簡略化です。 このコードではItem内の配列データを、さらに配列変数のmyArに代入して、要素ごとにForNextで回しましたが、配列変数にわざわざ代入しなくとも出来る方法があるかどうかが知りたいのです。 あるいはまったく別な方法でもかまいません。 ご教示いただければ幸いです。 Sub ItemsTest() Dim myDic As Object, ns As Worksheet '変数宣言 Dim c As Range, cc As Range, i As Integer Dim myAr Set myDic = CreateObject("Scripting.Dictionary") 'myDicを用意 For Each c In Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp)) 'A列の各データについて If Not myDic.exists(c.Value) Then 'myDicになければ myDic.Add c.Value, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value, c.Offset(0, 4).Value) '追加しB~E列データを配列でItemに Else 'myDicにあれば myAr = myDic(c.Value) 'Itemを配列myArに For i = LBound(myAr) To UBound(myAr) myAr(i) = myAr(i) + c.Offset(0, i + 1).Value '配列の要素ごとに加算 Next i myDic(c.Value) = myAr '配列myArをItemにもどす End If Next c '繰り返し Set ns = Worksheets.Add(After:=ActiveSheet) 'シートを追加 ns.Range("A1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) 'A列にKeyデータ転記 For Each cc In ns.Range("A1:A" & myDic.Count) cc.Offset(0, 1).Resize(, UBound(myAr) + 1).Value = myDic.Item(cc.Value) 'B~E列にItemデータ転記 Next End Sub  (o。_。)oペコッ

  • エクセルVBA教えて下さい

    エクセルの表で -AB C D E F 1年月--1801 2------ 3------ 4------ (-)は空欄でセルE1=18、F1=1とします。 コントロールボックスをつかって Private Sub Command登録_Click() d1 = Range("A65536").End(xlUp).Row d2 = Range("B65536").End(xlUp).Row Cells(d1 + 1, 1) = Range("E1").Value Cells(d2 + 1, 2) = Range("F1").Value End Sub とすると、登録コマンドを押すたびに次々セルA,Bに同じ数値が登録されるのですが、一回登録した数値を2度登録できないようにする方法はありませんか?  要は、この表だと18と1という条件では、2度登録できないようにしたいのです。よろしくお願いします。

  • VBAの検索で回答をいただいたのですが・・・

    Excel2010VBAの検索で、シート1のE列(2行目から)の「日時」とシート2のE列(2行目から)の日時が一致した場合、シート2のF列(2行目から)からJ列(2行目から)、またはJ列にデータがない場合は、F列(2行目から)からI列(2行目から)にデータを入力するというプログラムを高速化する方法を回答者様から教えていただきました。 シートの内容としては シート1は、A「年」、B「月」、C「日」、D「時刻」、E「日時」(文字列)、F「データ1」、G「データ2」、H「データ3」、I「データ4」、J「データ5」、(1行目はタイトル) シート2も基本的にはシート1と同じです。 教えていただいたプログラムは以下の通りで、これを元にシート3(シート1と同じ配列)のE列の日時とシート2のE列の日時が一致した行のシート3のF~J列(データ1~データ5)、J列のデータがない場合、F~I列(データ1~データ4)のデータをシート2のK~O列(データ1~データ5)に入力するというプログラムを作りたかったのですが、自分にとってはこのプログラムの内容が理解できないため、どこを修正していいか分かりません。 どなたか解説していただけませんか? Sub xxx3() Dim myDic As Object Dim S1_v, S2_v Dim i As Long, n As Long, j As Long 'With Workbooks("ブック.xlsm").Worksheets("シート1") With Sheets("Sheet1") j = .Range("E" & Rows.Count).End(xlUp).Row S1_v = .Range("E1").Resize(j, 6).Value '対象範囲を配列に End With 'With Workbooks("ブック.xlsm").Worksheets("シート2") With Sheets("Sheet2") j = .Range("E" & Rows.Count).End(xlUp).Row S2_v = .Range("E1").Resize(j, 6).Value '対象範囲を配列に End With Set myDic = CreateObject("Scripting.Dictionary") For i = 2 To UBound(S1_v) myDic.Add S1_v(i, 1), i 'keyに追加、itemにi Next i For i = 2 To UBound(S2_v) If myDic.exists(S2_v(i, 1)) Then j = myDic.Item(S2_v(i, 1)) S2_v(i, 2) = S1_v(j, 2) S2_v(i, 3) = S1_v(j, 3) S2_v(i, 4) = S1_v(j, 4) S2_v(i, 5) = S1_v(j, 5) S2_v(i, 6) = S1_v(j, 6) Else 'マッチしなかったときの処理 End If Next 'With Workbooks("ブック.xlsm").Worksheets("シート2") With Sheets("Sheet2") j = .Range("E" & Rows.Count).End(xlUp).Row .Range("E1").Resize(j, 6).Value = S2_v End With Set myDic = Nothing Erase S1_v, S2_v End Sub 回答よろしくお願いします。

  • エクセルでDictionaryオブジェクト

    メリークリスマス! とはいうものの仕事が終わりません。 これまでエクセルでDictionaryオブジェクトを利用し、AN列にある人名データをKeyにしてT列にある金額の集計を行っていました。 条件 AN列のデータには重複するものが多いが同姓同名は存在しない。 T列には必ず数値が入力されている。 AN列にある人名ごとにT列にある金額の集計を行う。 省略してますが以下のようなコードです。 Sub test01()   Dim myDic As Object   Dim x As Long   Dim myC As Range   Dim ws As Worksheet   Set myDic = CreateObject("Scripting.Dictionary")   x = Cells(Rows.Count, "AN").End(xlUp).Row   For Each myC In Range("AN1:AN" & x) '受取人名列     If Not myDic.Exists(myC.Value) Then       myDic.Add myC.Value, Cells(myC.Row, "T").Value 'T列の金額     Else       myDic(myC.Value) = myDic(myC.Value) + Cells(myC.Row, "T").Value '金額を加算     End If   Next   Set ws = Worksheets.Add(After:=ActiveSheet)   With ws '新規ワークシート     .Range("A1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.keys) 'A列にデータ     .Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Items) 'B列に結びつけ金額データ   End With   Set myDic = Nothing End Sub これでうまくできていたのですが、今回新しい条件が加わり、頭を悩ませております。 新たな条件とは、同じ表のN列にあるコード(数字8桁)のうち、例えば77777777のものがあれば、追加したワークシートのC列にフラグをたてるというものです。 どのようにすればできるでしょうか? よろしくお願いいたします。

  • エクセルVBAについて

    http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを E列に日付 F列に売上 G列に結果 でやりたいのですが この時A列~C列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか?

  • エクセルVBA

    A列を基準にBC列が空白ならAの数値を入れて、A>BならB列を更新、A<CならC列を更新 A列が数値以外ならその行をスキップ、という処理をしたいのですが Option Explicit Dim A As Range, B As Range, C As Range Dim i As Long Sub test() For i = 1 To 10 Set A = Cells(i, 1) Set B = A.Offset(0, 1) Set C = A.Offset(0, 2) If IsNumeric(A) Then Else Exit Sub End If If B.Value = "" Then B.Value = A.Value If C.Value = "" Then C.Value = A.Value If A.Value > B.Value Then B.Value = A.Value If A.Value < C.Value Then C.Value = A.Value Next i End Sub とすると数値以外の行の時点で停止してしまいます。 その行を飛ばして次の行に進むにはどうしたらいいのでしょうか?

  • エクセルVBAで最小値を求めたいのですが

    下記はある表の最大値を求めるものですが 同様の条件で最小値を求めようと思い 「MAX」の箇所を「MIN」差し替えてできると思っていたのですが 最小値がのかわりに「0」が表示されてしまいます。 そのように修正すればよいでしょうか? private sub worksheet_change(byval Target as excel.range)  if target.cells(1) = "" then exit sub  if target.address = "$A$1" then   Range("C10:C65536").ClearContents   With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C"))    .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)"    .Value = .Value   End With  elseif target.address = "$E$1" then   Range("G10:G65536").ClearContents   With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G"))    .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)"    .Value = .Value   End With  end if end sub

専門家に質問してみよう