エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage1.html
最初に正解された方に200ポイント、2位以降の方に50ポイント差し上げます。

なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えていただくことを回答の条件とさせていただきます。
http://q.hatena.ne.jp/1158311664

回答の条件
  • 1人2回まで
  • 登録:2007/02/12 11:38:51
  • 終了:2007/02/12 13:32:50

回答(3件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692007/02/12 12:16:35

ポイント50pt
    ' 使う変数の宣言
    Dim i As Integer
    Dim j As Integer
    Dim suuji As Integer
    Dim moji As Integer
    
    ' 文字のある列と数字のある列が何列目かを指定します。列が違うときはここを変更します。
    suuji = 2
    moji = 1
    
    ' シートを増やします
    Sheets.Add
    
    ' 増やしたシートに名前をつける
    ActiveSheet.Name = "科目合計"
    
    With Worksheets("科目合計")
        ' 増やしたシートの見出しをピンクに(ここで数字を変えると色が変わります)
        .Tab.ColorIndex = 38
        i = 1
        
        ' Sheet1の1行目から文字が空白になるまでループします
        While Worksheets("Sheet1").Cells(i, moji).Value <> ""
            j = 1
            ' 科目合計シートの1行目からSheet1の文字が同じ文字かどうかを比較します。
            While (Worksheets("Sheet1").Cells(i, moji).Value <> .Cells(j, 1).Value) And (.Cells(j, 1).Value <> "")
                j = j + 1
            Wend
            ' 比較されて同じ文字がある行数がjに入るか、同じ文字がないときは最初の空白行がjに入ります。
            ' 文字列をコピーして、数値を加えます。
            .Cells(j, 1).Value = Worksheets("Sheet1").Cells(i, moji).Value
            .Cells(j, 2).Value = .Cells(j, 2).Value + Worksheets("Sheet1").Cells(i, suuji).Value
            i = i + 1
        Wend
    End With
id:taroemon

ご回答ありがとうございます。


「実行エラー9。インデックスが有効範囲にありません」というエラーメッセージが出てしまいます。

「While Worksheets("Sheet1").Cells(i, moji).Value <> ""」に問題があるようです。

おそらく良い物だと思うのですが、私の環境とつたない技術では、思うようにはいきませんでした。

2007/02/12 13:19:07
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982007/02/12 12:34:11

ポイント200pt

Sub Macro1()

'

' Macro1 Macro

'

' Keyboard Shortcut: Ctrl+q

'

zz = "A" '←科目名があるセル

zx = "B" '←金額があるセル

b = "科目合計" '←追加するシート名

'

'現在 アクティブのシート名を取得

a = ActiveSheet.Name

'シート追加

Sheets.Add

'追加したシート名を取得

c = ActiveSheet.Name

'追加したシート名の変更

Sheets(c).Name = b

'追加したシートの色の変更

ActiveWorkbook.Sheets(b).Tab.ColorIndex = 38



'合計取得

For a1 = 1 To 65536

If Sheets(a).Range(zz & a1) = "" Then Exit For

For b1 = 1 To 65536

'何もないセルだったら

If Sheets(b).Range(zz & b1) = "" Then

'科目名をセット

Sheets(b).Range(zz & b1) = Sheets(a).Range(zz & a1)

'金額をセット

Sheets(b).Range(zx & b1) = Sheets(a).Range(zx & a1)

Exit For

Else

'同じ科目だったら 加算

If Sheets(b).Range(zz & b1) = Sheets(a).Range(zz & a1) Then

'金額をセット

Sheets(b).Range(zx & b1) = Sheets(b).Range(zx & b1) + Sheets(a).Range(zx & a1)

Exit For

End If

End If

Next b1

Next a1

End Sub

id:taroemon

ご回答ありがとうございます。

完璧にできました。

2007/02/12 13:20:20
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692007/02/12 13:00:25

ポイント50pt

基本は変わりませんが、複数のシートがあった場合と科目合計シートがすでにある場合を考慮していじってみました。

    ' 使う変数の宣言
    Dim i As Integer
    Dim j As Integer
    Dim suuji As Integer
    Dim moji As Integer
    
    ' アクティブなシートの取得
    Dim mySheet As Worksheet
    Set mySheet = ActiveSheet
    
    ' 科目合計があった場合クリア
    Dim ws As Worksheet
    Dim flag As Boolean
    For Each ws In Worksheets
        If ws.Name = "科目合計" Then
            flag = True
        End If
    Next ws
    
    ' 科目合計がない場合(flag=false)科目合計を追加
    If flag Then
         Worksheets("科目合計").Cells.Clear
    Else
       ' しーとを増やして名前をつける
        Worksheets.Add before:=Worksheets(1)
        ActiveSheet.Name = "科目合計"
        ' 増やしたシートの見出しをピンクに(ここで数字を変えると色が変わります)
        ActiveSheet.Tab.ColorIndex = 38
    End If
    
    ' 文字のある列と数字のある列が何列目かを指定します。列が違うときはここを変更します。
    suuji = 2
    moji = 1
    
    With Worksheets("科目合計")
        i = 1
        
        ' Sheet1の1行目から文字が空白になるまでループします
        While mySheet.Cells(i, moji).Value <> ""
            j = 1
            ' 科目合計シートの1行目からSheet1の文字が同じ文字かどうかを比較します。
            While (mySheet.Cells(i, moji).Value <> .Cells(j, 1).Value) And (.Cells(j, 1).Value <> "")
                j = j + 1
            Wend
            ' 比較されて同じ文字がある行数がjに入るか、同じ文字がないときは最初の空白行がjに入ります。
            ' 文字列をコピーして、数値を加えます。
            .Cells(j, 1).Value = mySheet.Cells(i, moji).Value
            .Cells(j, 2).Value = .Cells(j, 2).Value + mySheet.Cells(i, suuji).Value
            i = i + 1
        Wend
    End With
id:taroemon

ご回答ありがとうございます。

こちらの方が私の思っていた物より優れているようです。

新しいご提案ありがとうございます。

ただ複数のシートをアクティブにして実行したところ、最初のシートは算出されるのですが、他のシートが空白になってしまいます。やり方が悪いのでしょうか?

この問題点が解決されることと、複数のアクティブにしたシートがひとつの「科目合計」シートで合計されるよう作っていただければ、もう200ポイント差し上げます。

よければ作って下さい。もし作っていただけるなら、ポイント送信か、コメントでご回答下さい。おりかえしポイント送信させていただきます。

2007/02/12 13:32:05
  • id:taroemon
    SALINGER様
    複数シートを一つにまとめることできました。
    こちらの設定ミスです。
    また機会がありましたらご回答ください。
  • id:SALINGER
    上は図1のシートを勝手にSheet1としていました。すいません。
    複数のアクティブなシートを取得するのは確かできないような・・・。
  • id:taroemon
    >複数のアクティブなシートを取得するのは確かできないような・・・。
    あれ?なぜかできたのですが。
    僕の勘違いか、回答者2の方のスクリプトを間違えて使ったのかもしれませんね。

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません