• 締切済み

エクセルVBA　Range３か所に合致する合計額

お世話になります。エクセルRange("A")からRange("L") & LastRowまで入力してあります。 Range("B３")列以下には会社名Range("D３")列以下には班名Range("J３")列以下には品名がありRange("L3")列以下に合計額が入力されています。 この入力された中から（A,D,Jに合致する合計額）これをWorkBooks.Add　 sheets("sheet1").Range("A2")に出力したいのです.どなたか宜しくお願いします。

みんなの回答

  • SI299792
  • ベストアンサー率48% (714/1472)
回答No.2

　まだわかりません。 　会社名の合計を計算して、ということは、会社ごとに、A,B,D,J 列を合計しろということでしょうか。しかし、 B列には会社名、 D列には班名、が入っているみたいなので足しようがありません。私の解釈が間違っているのでしょう。 　具体的にどのようにデータが入っていて、どのように出力したいか。元データと結果のサンプルを上げていただけますか。あなたのおっしゃることは難解なので、どうしてそうなるのかもできれば書いてください。

nebikitorikai
質問者

お礼

すみません、質問内容が少し間違って出しましたので新しくJpeg入りで質問しなおします。宜しくお願いします

  • SI299792
  • ベストアンサー率48% (714/1472)
回答No.1

何をやりたいのかわかりません。 今だに回答がないのは、他の人も分からないからだと思います。 （A,D,Jに合致する合計額）とは何なのか。 どことどこが合致すればいいのか。 Range("A2") ということは、答えは一つということでしょうが。 その辺を詳しくご記入ください。

nebikitorikai
質問者

お礼

有難うございます、わかりにくくてごめんなさい

nebikitorikai
質問者

補足

すみません、FirstRange（”A３”）からでA列に日付B列に会社名D列に班名J列に品名がありL列に合計額が入力されています。A~Lまでそれぞれ入力されていますが計算したいのはA,B,D,J列にそれぞれ入力されているものと同じ入力文のそれぞれ会社名の合計を計算して新しいブックにA~Lまでを出力させたいのです。宜しくお願いします

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • QエクセルVBARange３か所に合致する合計額２

    お世話になります。 下記は質問内容の現在の出力マクロです Private Sub CommandButton32_Click() Unload Me Sheets("入力").Select Set dic1 = CreateObject("Scripting.Dictionary") Sheets("入力").Select Set dic2 = CreateObject("Scripting.Dictionary") Sheets("入力").Select Set dic3 = CreateObject("Scripting.Dictionary") v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 10) dic1(sName) = dic1(sName) + v(i, 12) Next v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 2) dic2(sName) = dic2(sName) + v(i, 12) Next v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2 For i = 1 To UBound(v) sName = v(i, 4) dic3(sName) = dic3(sName) + v(i, 12) Next Workbooks.Add With Sheets("sheet1").Range("B3").Resize(dic1.Count) .Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items())) End With With Sheets("sheet2").Range("B3").Resize(dic2.Count) .Resize(, 2).Value = Application.Transpose(Array(dic2.Keys(), dic2.Items())) End With With Sheets("sheet3").Range("B3").Resize(dic3.Count) .Resize(, 2).Value = Application.Transpose(Array(dic3.Keys(), dic3.Items())) End With End Sub 前回質問からCD等もろもろ手抜きで書いたため少し違っています。 伝わるか心配ですが書き込みますので宜しくお願いします。 例、B列の重複した会社名C列の重複した支店加入者名D列の重複した班名そしてG列には重複した変更可能な重複した商品があります。重複したものをまとめてそれぞれに合計を出してBooks.AddのSheet1（現在はSheet1~sheet3に出力）に出力したいのです。その他の列は自動で出るように関数が張り付けてありますが質問には関係ないと思いますので割愛します。 つたない質問で申し訳ありませんがわかる方がありましたら回答をお願いします。 尚、（現在はSheet1~sheet3に出力）これではsheet1~sheet3を行ったり来たりで効率が悪くて困っています。宜しくお願いします

  • エクセルVBA 　どうしても動きません。

    お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません（データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します）。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします！！！！！！ Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。

  • Excel　VBAについて

    Excel　VBAについて教えて頂きたいのですが、 Sub test() Dim lastrow, r, i As Long Dim sh1, sh2 As String Dim ws As Worksheet lastrow = Cells(Rows.count, "D").End(xlUp).row For r = 7 To lastrow '7 For i = 1 To lastrow '4 sh1 = ActiveSheet.Cells(r, 4) ActiveSheet.Cells(r, 20) = _ Application.CountIfs(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3")) ActiveSheet.Cells(r, 21) = _ Application.CountIfs(Sheets(sh1).Range("C:C"), Range("F3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("C:C"), Range("F3")) ActiveSheet.Cells(r, 22) = _ Application.CountIfs(Sheets(sh1).Range("E:E"), Range("K3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("E:E"), Range("K3")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") ActiveSheet.Cells(r, 15) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") - 200 ActiveSheet.Cells(r, 18) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") + 200 ActiveSheet.Cells(r, 19) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) For Each ws In Worksheets ws.AutoFilterMode = False Next Next Next End Sub このコードは ActiveSheetで実行すると D列の7行目から最終行までに入力されている名前のシート（名前＝シートがあります） その、シートの参照先で C,D,E列がcountif関数を利用して O列がSubtotal関数を利用しています。 このコードでもやりやいことは実行できるのですが、 時間がかかりすぎてしまいます。 約20件あり約２分ほどかかります。パソコンによっては倍ほど時間がかかるかもです。 そこでなのですが、 もっと処理のスピードを上げたいのですが、 可能でしょうか？ 可能ならそのやり方をご教示ください。 よろしくお願い致します。

  • VBA ふたつおきに加算した時の合計の表示

    EXCELのVBAで下記のような表に対し、合計を求めるコードを作成しました。 　　　A　　　　　B　　　　C　　　　　D　　　E　　　～O P 1　　　　　　　　　　　　表題 2　　　　　　　　　　　小見出し 4 　　　　　　　　　　　　　4月　　　5月　　　6月　～3月　計 5　　　　　　　予約　　　100　　　200　　　100　　　 6　佐藤　　　手数　　　　30　　　20　　　　20　　 7　　　　　　　金額　　　130　　　220　　　120 8　　　　　　　予約　　　150　　　100　　　100 9　斉藤　　　手数　　　30　　　　20　　　　20 10　　　　　　金額　　　180　　　120　　　120 11　　　　　　予約　　　100　　　100　　　100 12加藤　　　手数　　　　20　　　30　　　　20 13　　　　　　金額　　　120　　　130　　　120 　　　・ 　　　・ 　　　・ 　　合計　　　　　　　　　430　　　470　　　　360　　←それぞれの金額だけを合計した値 ※人が増えたり減ったりしますので行数が３行づつ変化します。 　入力する人が限定されないため、セルへの計算式入力（消されてしまう可能性があるため）と、 　EXCELの機能（フィルター）などを使用して計算する方法がとれません。 この、合計の部分を求めるため、 Dim stRow As Long Dim lastRow As Long stRow = 5 lastRow = Range("F" & stRow).End(xlDown).Row For i = 4 To lastRow For J = 4 To 15 Cells(lastRow + 1, J).Select Cells(lastRow + 1, J).Value = Application.WorksheetFunction.SumIf(Range(Cells(stRow, "F"), _ Cells(lastRow, "F")), "金額", Range(Cells(stRow, J), Cells(lastRow, J))) Next Next これで、合計の欄にそれぞれの月の合計が出るようにはなったのですが、 入力値に変更を加えて再度計算をしたときに、 『一番最後のセルのしたに合計値を出す』としたため、 下に計算結果が（それも、すでに出ていた合計値を加算して）表示されてしまいます。 これを必ず合計の行に出していくには、合計の行が変化するため、 どのようなコードで書けば良いのかがわかりません。 よろしくお願いします。

  • エクセルのフォームのVBAについて

    VBAがまったくわからないのに参考書を見て高度な事に挑戦しています フォームは作れてフォームをクリックやら入力やらして作ったOKボタンを押すと シート2のA1B1C1‥の列に入力文字だけが羅列されます。 しかし次にやろうとするとA2B2C2‥と下に行かず又A1B1C1‥の列の文字が変更になり続きません。何がいけないのでしょうか？ Sub 入力() Dim LastRow As Long With Worksheets("sheet2") LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row .Range("A" & LastRow).Value = Worksheets("sheet1").Range("A5").Value .Range("B" & LastRow).Value = Worksheets("sheet1").Range("A7").Value .Range("C" & LastRow).Value = Worksheets("sheet1").Range("A8").Value .Range("D" & LastRow).Value = Worksheets("sheet1").Range("A10").Value End With End Sub と参考書とおりいれたのですが‥。教えて下さい。

  • エクセルVBA　無駄な部分をおしえてください

    VBA初心者です。 多数のシートを条件によって二つのブックに分ける、というVBAを作ろうとしています。 なにぶん素人なので、無駄な文章が多いのではないかと心配で、 お知恵を拝借できればと思い投稿いたしました。どうぞよろしくお願いいたします。 やりたいこと：Book1のA列に100程度の文字列があり、そのいずれかと一致するシート名（Book1のSheets(2)以降）を持つシートはBook2の最終シートの後ろへ、どの文字列ともシート名が一致しないシートはBook3の最終シートの後ろへ移動。（「最終シートの後ろへ移動」がうまくいっていません） VBAの内容：Book1のH1に「=countif(A:A,G1)」と入力しておき、G1にシート名を入力させ H1>0ならば該当シートをBook2へ、それ以外はBook3へ移動　の繰り返し 　　Application.ScreenUpdating = False Dim j As Integer, k As Integer j = Workbooks("Book2.xls").Worksheets.Count k = Workbooks("Book3.xls").Worksheets.Count Do While Workbooks("Book1.xls").Sheets.Count > 1 Range("G1").Value = Worksheets(2).Name If Range("H1").Value > 0 Then Worksheets(2).Move after:=Workbooks("Book2.xls").Sheets(j) Else Worksheets(2).Move after:=Workbooks("Book3.xls").Sheets(k) End If Loop

  • VBAエクセル、項目検索からデータ抽出

    お世話になります。早速ですがsheets("データ元").Range("A2")にNo.、Range("B2")に日付、Range("C2")に曜日、Range("D2")に項目、Range("E2")に詳細、Range("F2")に金額があり A3～F3以下LastRowまでデータが入っています。 Range("D3"）以下LastLowの中から１会社名を検索するとその会社名すべてのデータが新規ブックSheet1に書き出され、そのシートのRange("G3")に合計額を出す構文をどなたかご教示ください宜しくお願いします。エクセル２００３と２０１３を各パソコンで使用しています。

  • エクセルVBAで困っています。

    　エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。 　ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の３つでした。その項目を９つに増やしたいと思っています。又、全てのSheetで１行目には銀行名や項目名を入れたいので２行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で（適当ですが）挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー：B列。[項目]昇順。 '第二優先キー：A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • 文字の合致で合計個数を表示

    A列文字とB列文字を連ねた文字がC列の文字に合致した場合、その個数合計をD列に示したいのですがその際、A列記号の数字は無視するものとします。 どなたかD列セル数式入力が解る方宜しくお願いします。

  • Excel-VBA rangeプロパティの使い方について

    Excel-VBA rangeプロパティの使い方について VBA初心者です。いろいろ調べたのですが、分からないので教えてください。 ThisWorkbookのSheet1のA1セルに、aというファイルのaというシートの特定のセルの値をコピーしたいです。 コピーする値のセルは、ThisWorkbookで入力した値を基に変数で記述したいです。 例えば、ThisWorkbookのSheet1のC2セルに「D1」と記載していたとして、その値を変数として設定して、最終的にaというファイルのaというシートの「D1」セルをThisWorkbookのA1セルに貼り付けるのが目的です。 この場合の、下記のhensuu = の設定方法について、ご教授願います。 hensuu = ThisWorkbook.Sheets("Sheet1").Range(“A1”)= Workbooks(a).Sheets(a).Range(hensuu)

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する