• 締切済み

Excel VBAで条件に合わせて行をまとめる

Excel VBAは初心者なので皆様のお知恵を拝借したいです。 No列、名称列、年月列、金額A列、金額B列があるExcelファイルを 以下のような条件のときに行をまとめたいです。 【まとめる条件】 ・Noが同じである ・年月が同じである ・名称に★マークが含まれていない 列をまとめた際の名称は一番上の名称をしようします。 また金額A・Bはそれぞれ合算したいです。 お知恵のある方はどうかお力をお貸しください。 よろしくお願い致します。

みんなの回答

  • kkkkkm
  • ベストアンサー率65% (1624/2465)
回答No.4

No3一部抜けがありましたので訂正です Sub Test() Dim LastRow As Long Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Sheets("Sheet1") Set Sh2 = Sheets("Sheet2") Sh1.Range("A1").AutoFilter Sh1.Activate Sh1.Range(Cells(1, "A"), Sh1.Cells(Rows.Count, "E").End(xlUp)).AutoFilter Field:=2, Criteria1:="<>*★*", _ Operator:=xlAnd Sh1.Range(Cells(1, "A"), Sh1.Cells(Rows.Count, "E").End(xlUp)).Copy Sh2.Range("A1").PasteSpecial Application.CutCopyMode = False Sh2.Activate Sh2.Range(Cells(1, "A"), Sh2.Cells(Rows.Count, "E").End(xlUp)).RemoveDuplicates Columns:=Array(1, 3), Header _ :=xlYes Sh2.Range("D2").Select Sh2.Range("D2").Formula = _ "=SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,""<>*★*"")" Sh2.Range("D2").AutoFill Destination:=Sh2.Range("D2:E2"), Type:=xlFillDefault LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row Sh2.Range("D2:E2").AutoFill Destination:=Sh2.Range(Sh2.Cells(2, "D"), Sh2.Cells(LastRow, "E")), Type:=xlFillDefault Set Sh1 = Nothing Set Sh2 = Nothing End Sub

  • kkkkkm
  • ベストアンサー率65% (1624/2465)
回答No.3

エクセルのマクロの記録でほとんどのコードが取得できます。ただし単純なデータで確かめただけなので結果が絶対正しいとは言えません。 もとのデータがSheet1の No列がA列、名称列がB列、年月列がC列、金額A列がD列、金額B列がE列 1行目が項目2行目からデータ でSheet2にまとめたデータをA1から記載する場合として マクロの記録を始めます 1)Sheet1のA1を選択して並び替えとフィルターでフィルターをオンにします。 2)名称列(B列)のフィルターでテキストフィルターで指定の値を含まないを選択して★を指定します。 3)フィルターされたデータの全ての範囲をコピーしてSheet2のA1に貼り付けます。バージョンによっては見えないセルもコピーされるかもしれません。その場合Alt+;を押してからコピーしてください。 4)Sheet2の貼り付けたデータをすべて選択してデータタブの「重複の削除」でNo列と年月列を選択して実行します。 5)金額A列のD2を選択して以下の数式を入れます。 =SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,"<>*★*") 6)D2をE2までフィルします。D2とE2をデータの最後の行までフィルします。 マクロの記録終了 以下はA1からE21までデータがある場合のマクロの記録でできたコードです。 Sub Macro1() Range("A1").Select Selection.AutoFilter Range("A1:E21").Select ActiveSheet.Range("$A$1:$E$21").AutoFilter Field:=2, Criteria1:="<>*★*", _ Operator:=xlAnd Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveSheet.Range("$A$1:$E$18").RemoveDuplicates Columns:=Array(1, 3), Header _ :=xlYes Range("D2").Select ActiveCell.FormulaR1C1 = _ "=SUMIFS(Sheet1!C[-2],Sheet1!C1,Sheet2!RC1,Sheet1!C3,Sheet2!RC3,Sheet1!C2,""<>*★*"")" Range("D2").Select Selection.AutoFill Destination:=Range("D2:E2"), Type:=xlFillDefault Range("D2:E2").Select Selection.AutoFill Destination:=Range("D2:E6"), Type:=xlFillDefault End Sub 以下は上記をもとに冗長な部分を整理して、行数が増えても対応できるように変更したものです。 Sub Test() Dim LastRow As Long Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Sheets("Sheet1") Set Sh2 = Sheets("Sheet2") Sh1.Range("A1").AutoFilter Sh1.Activate Sh1.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).AutoFilter Field:=2, Criteria1:="<>*★*", _ Operator:=xlAnd Sh1.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).Copy Sh2.Range("A1").PasteSpecial Application.CutCopyMode = False Sh2.Activate Sh2.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).RemoveDuplicates Columns:=Array(1, 3), Header _ :=xlYes Sh2.Range("D2").Select Sh2.Range("D2").Formula = _ "=SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,""<>*★*"")" Sh2.Range("D2").AutoFill Destination:=Range("D2:E2"), Type:=xlFillDefault LastRow = Cells(Rows.Count, "A").End(xlUp).Row Sh2.Range("D2:E2").AutoFill Destination:=Range(Cells(2, "D"), Cells(LastRow, "E")), Type:=xlFillDefault Set Sh1 = Nothing Set Sh2 = Nothing End Sub

  • HohoPapa
  • ベストアンサー率65% (454/692)
回答No.2

シートのレイアウトがわからないので ・タイトル行が1行目にある。 ・No.列は途中の行に空欄がない(上方向に詰まっている) という条件にしてみました。 また、まとめる条件は以下ですね? ・Noが同じである かつ、 ・年月が同じである かつ、 ・名称に★マークが含まれていない 添付画像の内容なら 以下のコードで期待の動作になるものと思います。 Sub Sample()  '変数定義  Dim wsGet As Worksheet  Dim wsPut As Worksheet  Dim i As Long  Dim j As Long  Dim RecCnt As Long    '定数定義(それぞれ列番号)  Const ColN = 1 'No.列  Const ColM = 2 '名称列  Const ColD = 3 '年月列  Const ColK1 = 4 '金額1列  Const ColK2 = 6 '金額2列  Const wkColNum1 = 8  '作業列1  Const wkColNum2 = 9  '作業列2    'ワークシート定義  With ThisWorkbook   Set wsGet = .Sheets("Sheet1")  '集計元シート   Set wsPut = .Sheets("Sheet2")  '集計先シート  End With    '作業領域クリアー  wsGet.Columns(wkColNum1).ClearContents  wsGet.Columns(wkColNum2).ClearContents    '作業列編集  i = 2  Do   If wsGet.Cells(i, ColN).Value = "" Then Exit Do   If InStr(wsGet.Cells(i, ColM).Value, "★") = 0 Then    wsGet.Cells(i, wkColNum1).Value = _     wsGet.Cells(i, ColN).Value & _     wsGet.Cells(i, ColD).Value   Else    wsGet.Cells(i, wkColNum1).Value = _     i & "_" & _     wsGet.Cells(i, ColN).Value & _     wsGet.Cells(i, ColM).Value & _     wsGet.Cells(i, ColD).Value   End If   i = i + 1  Loop  wsGet.Columns(wkColNum1).Copy wsGet.Columns(wkColNum2)  wsGet.Columns(wkColNum2).RemoveDuplicates Columns:=1, Header:=xlNo  '統合転記先クリアー、タイトル行出力  wsPut.Cells.ClearContents  wsGet.Rows(1).Copy wsPut.Rows(1)    '作業列をもとに統合転記  RecCnt = i - 2  'データの総レコード数取得  i = 2  'MsgBox RecCnt  Do   If wsGet.Cells(i, wkColNum2).Value = "" Then Exit Do   For j = RecCnt + 1 To 2 Step -1    If wsGet.Cells(j, wkColNum1).Value = _     wsGet.Cells(i, wkColNum2).Value Then     wsPut.Cells(i, ColN).Value = wsGet.Cells(j, ColN).Value     wsPut.Cells(i, ColM).Value = wsGet.Cells(j, ColM).Value     wsPut.Cells(i, ColD).Value = wsGet.Cells(j, ColD).Value     wsPut.Cells(i, ColK1).Value = _      wsPut.Cells(i, ColK1).Value + wsGet.Cells(j, ColK1).Value     wsPut.Cells(i, ColK2).Value = _      wsPut.Cells(i, ColK2).Value + wsGet.Cells(j, ColK2).Value    End If   Next j   i = i + 1  Loop    '作業列クリアー ' wsGet.Columns(wkColNum1).ClearContents ' wsGet.Columns(wkColNum2).ClearContents End Sub

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

>VBAは初心者なので 文法を齧っても、下記のような「処理ロジック」の訓練をしなければ、駄目で、 いろんなケースに出くわして、真似るほかない。 ーー 以下はソート法とでもいうべき処理ロジック。 (1)A列(NO)でソートしてみて そのNO順に並んでいる各Noの切れ目で、直前のNoの金額A列、金額B列の 出せばよいのでは。 (2)年月については、ソートの結果が、年月順になるかどうかやってみればよい。もし乱れるようなら、年数字4桁+月数字2桁のデータを新しい列に作って、その列でソートして(1)と同じ考え方法を適用する。 (3)名称に★マークが含まれていない は、p=Instr(セルの値、”★")で判別すればよい。 ーー A,B冽データ A1:B6 名前 計数 AA★A 2 BBB 3 CC★ 4 DDD 5 ★SSD 6 標準moduleに Sub test01() s = 0 For i = 2 To 6 p = InStr(Cells(i, "A"), "??") If p <> 0 Then s = s + Cells(i, "B") Next i MsgBox s End Sub 結果 6が表示される。 ーーー 例データ A1:B8 NO 計数 1 1 1 2 2 3 2 4 2 5 3 6 3 7 標準モジュール Sub test02() Dim mae k = 2 '---最初のデータ行 mae = Cells(2, "A") s = s + Cells(2, "B") '---第3行以下 For i = 3 To 8 If Cells(i, "A") = mae Then s = s + Cells(i, "B") Else '変わった Cells(k, "F") = mae Cells(k, "G") = s k = k + 1 s = 0 'ご破算 mae = Cells(i, "A") s = s + Cells(i, "B") End If Next i '-- Cells(k, "F") = mae Cells(k, "G") = s End Sub ーー 実行後F2:G4 1 3 2 12 3 13 === 関数SUMIF法 No列や名称列の、重複のないデータを1列に作れるなら(フィルタオプションで作れる) そのデータをSUMIF関数の条件にして、計数列の係数の合計などが出せる。 =SUMIF(A2:A8,F2,B2:B8)下へ式を複写。 F列  G列 I列=式を入れた列。 1 3 3 2 12 12 3 13 13 関数から学び始めた人はこれがよいかも。 I1 3 3 2 12 12 3 13 13 1 3 3 2 12 12 3 13 13 VBAなら Sub test03() For i = 2 To 4 Cells(i, "I") = Application.WorksheetFunction.SumIf(Range("a2:A8"), Cells(i, "F"), Range("B2:B8")) Next i End Sub === 「年月が同じである」分は、模擬データを挙げてくれればやってみる。 年月データの扱いは、エクセルでは要注意ですから、軽々しく回答できない。

関連するQ&A

  • Excelで複数条件を満たすのは何行目?

    Excel VBAにてどういう方法があるのか考えています。 A列はHかL、B列は1,2,3のようなデータにおいて  条件1:A列はH  条件2:B列が2 を満たす行は何行目かを探して、C列のその行のセルに コピーしていたデータを貼り付けたい (この場合、2つの条件で重複する行はありません) A列 B列 C列 H  1 H  2  ■←ここへ貼り付け H  3 L  1 L  2 L  3 この場合は、2行目なので、C列の2行目のセルをselectしてpasteしたいのです。 良い方法をご存じの方、よろしくお願いいたします。

  • エクセルの行削除VBA

    次の条件を満たすエクセルVBAの記述を教えてください。 A列に「ページTOP」の文字がある行から文末までの行を削除 A列に「PROGRAM…」のある行と次の1行を残して「4:00~…」を含む行までを削除 (例 A10 PROGRAM… A11 AB A12 hij A13 tuy A14 4:00… ※A12~A14を削除 A1からA列に「PROGRAM…」のある行まで行削除 Excel2010/WindowsXP

  • 複数条件抽出をVBAで

    excelの複数条件抽出をVBAでやりたいので教えてください。 エクセル2003で複数条件抽出をしたいと思っています。 dateのシートに、A列:日付、B列:名前、C列:金額があります。 それを1というシートに、日付と名前の2つの条件が合致している金額を抜き出したいと思っています。 抜き出すのは0601&AさんをA5セル~A20       0601&BさんのはB5~B20へ ということは可能でしょうか? もしよろしければ教えていただければ助かります。 'date'シート 日付   名前  金額 0601 Aさん  100円 0601  Aさん  120円 0601  Bさん  150円 シート'1' 0601&Aさん   0601&Bさん 100円           150円 120円 どの人がやってもボタン1つで実行できるようにしたいために、 VBA出できればと思っております。

  • EXCEL VBA 条件に合致しない行を削除したい

    超初心者です。どうか教えてください・・・m(_ _)m A列   B列   ・・・・・ 1234567  2345678 9876543  8765432  ・    ・  ・    ・ といった、表(数千行規模)があります。 A列とB列には7桁の数字があります。 A列とB列には途中ブランクのセルもあります。 A列またはB列のどちらかにも、 複数の範囲条件(数字)に合致しない行を削除したいです。 A列またはB列のどちらかに合致すればその行を残します。 複数の範囲条件(数字) (例)  1000000~1000009  2000100~2000199     ・     ・   十数個あります。 何卒、宜しくお願い致します。・・・m(_ _)m

  • エクセルのデータを条件を絞って合計を出したいのですが。

    エクセルのデータを条件を絞って合計を出したいのですが。 いつもこちらでお世話になってます。 B列に各事業所、 H列に金額 I列に請求開始月(2010年4月、2010年5月という入力) とデータがあり、 それぞれの事業所で、 何月にいくら金額があるかを調べたいのですが、 どのように抽出したら良いでしょうか? また、2010年4月に限っては それ以前(2009年12月など)のデータも合算したいのです。 どうかお知恵を拝借願います 宜しくお願いします。

  • Excel VBAでn行毎に行の選択

    Excel VBAでn行毎に行の選択 こんにちわ。 初めて質問をさせて頂きます。 今回ExcelのVBAを使ってあるシートを作成することになったのですが その過程で分からず、詰まっております。 色々調べてみたもののVBAの知識が浅いせいか 該当する様なものは見つかりませんでした。 実行したいのはタイトルの通りです。 例として10行毎に1行ずつ選択したい場合は下記の通りです。 A列 10行目←選択 ・ ・ 20行目←選択 ・ ・ 30行目←選択 ・ ・ 40行目←選択 実際にやりたいことは行を選択後に入力規則を入れたいだけなのですが 5000行近くあるので、一つ一つコードを書く場合 Range("A10,A20,A30,A40・・・").EntireRow.Select 結構な量になります・・・。 VBAなら他にもっと効率いいことができるのでは、と 自分なりに探してはいますが、どうしても見つからないので 皆様のお知恵をお借りしたいです。 よろしくお願いします。

  • エクセルVBA 条件にあうときセルを塗りつぶすには?

    エクセルVBA 条件にあうときセルを塗りつぶすには? エクセルVBAについて教えてください。 _________A 列 _________B 列_________C列_________D列 -------------------------------------------- 1行| 基準値_________ 5_____________1____________8 2行| りんご____________1_____________9____________0 3行| みかん___________12___________5____________3 4行| ぶどう____________15___________7____________8 5行| バナナ____________3_____________1____________4 上図のようにデータがあります。 (実物は列行共に膨大です。また条件を4つ以上つける予定なので条件付書式は使えません) 各列の基準値に対して、セルの増減が、0以下のときに黄色に、5から8のとき大きくなるときに赤、9以上のときに青にセルの色を塗りつぶしたいです。 どのようにすればよいでしょうか? B列の場合、基準値が5です。 B2のセルの場合、基準値5と1(B2セル)の増減は-4です。 増減が0以下のときは黄色に、増減が5から8のときは赤に、増減が9以上のときに青にするので、このときは黄色に塗りつぶします。 B3のセルの場合、基準値5と12(B3セル)の増減は7です。 増減が5から8のとき赤に塗りつぶすので、このセルは赤に塗りつぶします。 B4のセルの場合、基準値5と15(B4セル)の増減は10です。 増減が9以上のとき青色に塗りつぶすので、このセルは青色に塗りつぶします。 C2のセルの場合は、C列の基準値は1(C1セル)です。 基準値1と9(C2のセル)の増減は8です。 増減が5から8のとき赤に塗りつぶすので、このセルは赤に塗りつぶします。 よろしくお願いいたします。

  • エクセル2003のVBAを教えて

    エクセル2003のVBAを教えてください。 次の対象データで、(1)(2)(3)の作業が出来るエクセルVBAを教えて下さい。 (1)(2)(3)個々のVBAでお願いします。 ●対象データ:種類(A列)、文字(B列)、    データの行数:不特定なので、データのある最終行までとします。 ●教えていただきたい項目  (1):種類だけを(C列)に取り出す。  (2):種類の先頭に空白の行を3行入れて、追加の2行目の種類(A列)に文字(B列)を入れる。  (3):種類が5行以上あるときは、5行ごとに空白行を追加する。 ●対象データ 種類(A列)   文字(B列) AA       あああ BB       いいい BB       いい BB       いいい CC       うう CC       うう DD       ええええ DD       ええええ DD       ええええ DD       ええええ DD       ええええ DD       ええええ DD       ええええ ●(1)のVBAの結果(このようになるVBAを教えてください。) (C列) AA BB CC DD ●(2)、(3)のVBAの結果(このようになるVBAを教えてください。) 種類(A列)    文字(B列) あああ AA        あああ いいい BB        いいい BB        いいい BB        いいい うう CC        うう CC        うう ええええ DD        ええええ DD        ええええ DD        ええええ DD        ええええ DD        ええええ DD        ええええ DD        ええええ

  • エクセルVBAを教えてください。

    エクセルVBAを教えてください。 エクセル初心者です。 仕事の都合で下記のようなマクロを作らないといけないのですが作り方がよくわかりません・・・。 宜しくお願い致します。 ----------------------------------------------- 列A   列B   列C   列D 1行目  名前   金額   日時 2行目  Aさん  100円  12/1 3行目       200円  12/2 4行目       300円  12/3 5行目  合計   600円 6行目  Bさん  100円  12/1 7行目       200円  12/2 8行目       300円  12/3 8行目       400円  12/4 9行目  合計   1000円 10行目  Cさん  100円  12/1 11行目       200円  12/2 12行目  合計   300円 のExcel表があります。 これを下記のように変更したいです。 列を1つ挿入し、追加した列に合計行までそれぞれの人の名前をペーストしたいです。 列A   列B   列C   列D   列E 1行目  名前   名前   金額   日時 2行目  Aさん  Aさん  100円  12/1 3行目       Aさん  200円  12/2 4行目       Aさん  300円  12/3 5行目  合計   Aさん  600円      ←合計欄まで名前をコピーしたいです。 6行目  Bさん  Bさん  100円  12/1 7行目       Bさん  200円  12/2 8行目       Bさん  300円  12/3 8行目       Bさん  400円  12/4 9行目  合計   Bさん  1000円 10行目  Cさん  Cさん  100円  12/1 11行目       Cさん  200円  12/2 12行目  合計   Cさん  300円

  • Excel VBAでデータを自動処理したい

    Excelで大量のデータ処理をしなくてはならないのですが、以下の処理をExcel VBAで自動処理できないでしょうか? どなたかお知恵をお貸しください。 (1)A、B、C列からなるリストがあります。A,B列にはそれぞれオートフィルタが設定してあり、C列は空白です。A列、B列にそれぞれ条件を設定し、抽出したデータのC列(空白)に特定のデータを入力します。A列、B列2つの条件の組み合わせが100通りくらいあり、現在手動でオートフィルタを設定し、C列にデータを入力しております。例えばA,B列の条件の組み合わせと、それに対応するC列に入力するデータを表にしたテーブルを別に作り、A,B列の条件を自動に設定して、抽出し、C列にデータを自動に入力することを、テーブルの一番上の行から最後の行まで繰り返す、というようなことをVBAでExcelにしてもらいたいのです。自分でちゃんと勉強し、調べて、それでも分からなかったらお聞きするというのが筋だと思うのですが、今この仕事に追われて、時間がありません。(ほとんど毎日午前様です。)この仕事が片付いたら、じっくりVBAを勉強したいと思っております。どうぞよろしくお願いいたします。

専門家に質問してみよう