こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセルVBAで内容変更のたびに自動実行するには?

エクセルVBAでBOOK1のsheet1とsheet2とsheet3とsheet4があり、
sheet1とsheet2とsheet3の全ての情報をsheet4にコピーしてまとめるようにしました。
マクロを実行するには、Visual Basicを開いてF5を押しています。

それをsheet1かsheet2かsheet3の中身の一部分でも変更すると
そのときに自動的にマクロが実行されるようにしたいです。

エクセルを開いたときやsheetをアクティブにしたとき、日時を指定して実行させる
という説明はみつけましたが、sheet内の変更で実行というものはみつかりませんでした。

どのようにすれば良いのでしょうか?
よろしくお願いいたします。

投稿日時 - 2011-09-04 15:06:22

QNo.6988789

すぐに回答ほしいです

質問者が選んだベストアンサー

Sheet1,2,3それぞれのコード欄にて

Private Sub Worksheet_Change(ByVal Target As Range)

処理マクロ

End Sub

として実行させるか

Private Sub Worksheet_Change(ByVal Target As Range)

Call 処理マクロ名

End Sub

で別モジュール上のマクロを呼び出して実行してください。

投稿日時 - 2011-09-04 15:20:04

補足

ありがとうございます。

Sub マクロ()

Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub


これを↓のように変更しましたが、sheet1やsheet2のセルの内容(文章、色など)を変更してもsheet3に反映されませんでした。



Private Sub Worksheet_Change(ByVal Target As Range)

'ここから下は変更はありません。
Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub

投稿日時 - 2011-09-05 10:47:27

お礼

ありがとうございました。

投稿日時 - 2011-09-07 18:40:40

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

シートの変更処理の中で再度シート内の変更
Rows(RowCount).Delete
をしてるようなので

以下のように

Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False

実行したいマクロ

Application.EnableEvents = True

End Sub



Application.EnableEvents
の処理を追加してください。

投稿日時 - 2011-09-06 17:42:25

お礼

ありがとうございました。

投稿日時 - 2011-09-07 18:39:12

ANo.4

こんにちわ 初心者ですが間違っていたらごめんなさい
スレ主様は、コードを「標準モジュール」記述していませんか?
先に回答している方も書いている通り記述先は「seet1,2,3のコードウィンドウ」のChangeイベントです。
http://okwave.jp/qa/q685091.html

投稿日時 - 2011-09-05 13:06:43

補足

sheet1とsheet2とsheet3に

Private Sub Worksheet_Change(ByVal Target As Range)
Call マクロ()
End Sub

を入れ、




標準モジュールに

Sub マクロ()

Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer

Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub




をやって、sheet1かsheet2のセルを変更すると
エクセルが固まってしまいます。
デバックでは最初の
Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")
がよくないようです。
書き方が間違っているのでしょうか?

投稿日時 - 2011-09-05 14:47:28

お礼

ありがとうございました。

投稿日時 - 2011-09-07 18:39:37

ANo.3

>sheet内の変更
の「変更」の意味・範囲があいまいです。経験が余りなくて、色んなケースを想像できないのでしょうが。
「セルの値の変更」に限れば、下記が参考になるかも。
セルの属性に限っても、セルの値のほかに表示形式やコメントなど色々あるのを意識してますか?
ーー
勉強する方向は、「イベント」に関することだと思う。シートに限って言えば
(1)各シートでシートの
シートタブで右クリックー「コードの表示」で出て来る画面で
General部でWorksheet Declalation部でChangeを指定して
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
などを使う
(2)プロジェクトエクスプローラー部のThisWorkBookでShhetChange
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
End Sub
を使うことをやってみてください。
ーー
後者の参考
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
MsgBox Sh.Name & " " & Target.Address
End Sub
シート名をSheet1,Sheet2、Sheet3にVBAコードで限定すれば、その3シートを対象にした変更だけコードが書ける。
ーー
しかしこれで操作的(取り消しなども含めて)に、データ入力的(抹消・挿入なども含めて)に色々やってみて、ニーズを満たすかどうか?
私は疑問を持ちますのですが。
ーー
初心者は即時反応性を望む。本源的にはそれが望ましいが、ウインドウズ以前の昔の時代のコンピュター処理を見てきたものには大変なことだと思うから控えめに考える。
エクセルは、VBA程度だけで、突き詰めて即時反応性を追求するのは、関数を除いて難しいと思う。
必要の都度その時点(でボタンでも押させて)のデータで、VBAで改めて「まとめる」直すのが素直では。

投稿日時 - 2011-09-04 18:05:56

補足

ありがとうございます。

Sub マクロ()

Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub


これを↓のように変更しましたが、sheet1やsheet2のセルの内容(文章、色など)を変更してもsheet3に反映されませんでした。



Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'ここから下は変更はありません。
Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub

投稿日時 - 2011-09-05 10:46:22

お礼

ありがとうございました。

投稿日時 - 2011-09-07 18:40:20

ANo.2

各シートのマクロで

Private Sub Worksheet_Change(ByVal Target As Range)

実行したいマクロ

End Sub

を設定するか

ThsiWorkbookのマクロで

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name <> "Sheet4" Then
実行したいマクロ
End If

End Sub

といった設定にしてください。

投稿日時 - 2011-09-04 15:22:21

補足

ありがとうございます。

Sub マクロ()

Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub


これを↓のように変更しましたが、sheet1やsheet2のセルの内容(文章、色など)を変更してもsheet3に反映されませんでした。



Private Sub Worksheet_Change(ByVal Target As Range)

'ここから下は変更はありません。
Workbooks("BOOK.xlsm").Worksheets("sheet1").Range("C1:BE50").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C1:BE50")

Workbooks("BOOK.xlsm").Worksheets("sheet2").Range("C1:BE100").Copy _
Destination:=Workbooks("BOOK.xlsm").Worksheets("sheet3").Range("C51:BE150")

Dim UsedCell As Range
Dim Max_Row, RowCount As Integer


Set UsedCell = ActiveSheet.UsedRange

Max_Row = UsedCell.Cells(UsedCell.Count).Row
Application.ScreenUpdating = False
For RowCount = Max_Row To 1 Step -1

If Application.WorksheetFunction.CountA(Rows(RowCount)) = 0 Then
Rows(RowCount).Delete
End If
Next
Application.ScreenUpdating = True

End Sub

投稿日時 - 2011-09-05 10:47:10

お礼

ありがとうございました。

投稿日時 - 2011-09-07 18:41:03

あなたにオススメの質問