質問です

コード別に性別ごとに金額と件数を小計するマクロをお願いします
B列にコード(半角英数小文字)C列に男女、I列に金額のエクセルデータがあります
データは2行目から
B列    C列      I列
コード   性別     金額
aaaa    男      -1000
aaaa    男      -2000
bbbb    女      -1000
abcd    女      -1000
答え
2行目からデータ
同じコードの最後の行に答えの小計をだす
D列(男の金額)E列(男の数)F列(女の金額)G列(女の数)
A列にはB列とおなじコードを表示
A列    B列  C列    D列   E列    F列   G列    I列     
               男の金額と数     女の金額と数
      aaaa  男                         -1000
aaaa   aaaa  男    -3000  2              -2000
bbbb   bbbb  女              -1000  1    -1000 
abcd   abcd  女              -1000  1    -1000 

回答の条件
  • 1人3回まで
  • 登録:
  • 終了:2011/06/11 11:29:26
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント100pt
Sub main()
    'コードでソートされているのを条件として実行します。
    
    '1行もないとき
    If Cells(2, "B") = "" Then
        Exit Sub
    End If
    
    '初期値のセット
    c1 = Cells(2, "B")
    c2 = Cells(2, "C")
    If c2 = "男" Then
        d1 = Cells(2, "I")
        e1 = 1
    Else
        d2 = Cells(2, "I")
        e2 = 1
    End If
    
    '1行しかないとき
    If Cells(3, "B") = "" Then
        Cells(2, "A") = Cells(2, "B")
        If c2 = "男" Then
            Cells(2, "D") = d1
            Cells(2, "E") = e1
        Else
            Cells(2, "F") = d2
            Cells(2, "G") = e2
        End If
        Exit Sub
    End If
    
    d1 = 0
    d2 = 0
    
    e1 = 0
    e2 = 0

    For a = 2 To Cells(2, "B").End(xlDown).Row
        If Cells(a, "B") <> c1 Then
            Cells(a - 1, "A") = Cells(a - 1, "B")
            If e1 > 0 Then
                Cells(a - 1, "D") = d1
                Cells(a - 1, "E") = e1
            End If
            If e2 > 0 Then
                Cells(a - 1, "F") = d2
                Cells(a - 1, "G") = e2
            End If
            d1 = 0
            d2 = 0
            e1 = 0
            e2 = 0
        End If
        c1 = Cells(a, "B")
        If Cells(a, "C") = "男" Then
            d1 = Cells(a, "I") + d1
            e1 = e1 + 1
        Else
            d2 = Cells(a, "I") + d2
            e2 = e2 + 1
        End If
    Next a

    
    Cells(a - 1, "A") = Cells(a - 1, "B")
    If e1 > 0 Then
        Cells(a - 1, "D") = d1
        Cells(a - 1, "E") = e1
    End If
    If e2 > 0 Then
        Cells(a - 1, "F") = d2
        Cells(a - 1, "G") = e2
    End If

End Sub
id:inosisi4141

ありがとうございます。

結論的にはOKですが男の数が1件どうしても合いません

答えの男の数が1件多いみたいです。

金額は合っています。

よろしくお願いします。

2011/06/10 18:56:42

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません