人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。
http://hatena88.web.fc2.com/hatena/newpage1.html
最初に正解された方に200ポイント、2位以降の方に50ポイント差し上げます。

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

●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:VBA いただきます エクセル ポイント マクロ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●50ポイント
 ' 使う変数の宣言
 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
◎質問者からの返答

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


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

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

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


2 ● きゃづみぃ
●200ポイント

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

◎質問者からの返答

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

完璧にできました。


3 ● SALINGER
●50ポイント

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

 ' 使う変数の宣言
 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
◎質問者からの返答

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

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

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

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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ