【Excel2010＊マクロ】フォーマットの改訂

質問

マクロ（・ＶＢＡ）は、全くの初心者です。
あちこち調べてみたのですが、理解できませんでした。
今後は基礎から勉強していくべきと考えていますが、取り急ぎの対応を迫られています。

具体的には下記のようなことをやりたいのですが、マクロでの対応は可能でしょうか？
可能な場合、どのようにマクロを組んだらよいでしょうか？

ご教示のほど、よろしくお願いいたします。

===========================================================
　経費精算Excelフォーマットの改訂をしたい【Excel2010】
===========================================================

■現在の仕様
===================
・会場ごとに経費明細のシートが存在します。
　　→シートの枚数は、開催状況によって増減
　　→シート名は、毎回任意で変更される
・会場ごとの経費明細シートの総計を［まとめ］シートで一括集計します。

　＜補足＞明細のシートは余分な枚数を用意しておき、シートの増減がないように対応予定です。

■やりたいこと
===================
・会場ごとの経費明細の合計値を、［まとめ］シートへ引用したい。
　　→［まとめ］シートの任意の位置にシート名を入力すると、経費明細合計値が引用されてくるようなマクロを組みたい。

＜具体的には＞
---------------------------------
・［まとめ］シートのＢ列（１０行目～）へ、［会場明細］シートのシート名を入力すると
　経費合計の数値（［会場明細］シートのＤ９～Ｇ９/Ｑ９～Ｔ９）が、
　［まとめ］シート（例の場合、『111』はＣ１０～Ｇ１０/Ｍ１０～Ｐ１０）へ
　引用されてくるようにしたい。
・上記以下の行へも、同じ処理が行われるようにしたい。
---------------------------------------------------------------------------------------------------------

具体的なシートイメージも添付させていただきます。
何卒よろしくお願いいたします。

回答No.4

Mathmi · ベストアンサー

＞B列をクリアした時前の結果をクリアする
＞ブック名が変わった時、マクロを修正しないようにしたい
No.3の方に指摘頂きました重複入力禁止も含め、コードに反映しました。
(重複入力可なら、まとめシートのシートモジュールに入れるコードは変更不要です)
開いているブックの中から指定した名前のシートを検索し、そのデータを集計します。
同じ名前のシートが複数存在した場合、エラーが出るようになっています。

**********まとめシートのシートモジュール********************
Private Sub Worksheet_Change(ByVal Target As Range)
　Dim TargetRange As Range
　Set TargetRange = Union(Range("B10:B63"), Range("B65:B69")) '<-適宜変更。

　'変更されたセルが一つだけ、かつTargetRange内か
　If Target.Count = 1 And _
　 Not Intersect(Target, TargetRange) Is Nothing Then
　　'重複あればメッセージを出して終了、なければ集計マクロを起動
　　If IsDoubling(TargetRange, Target) Then
　　　MsgBox ("そのシート名は既に使用されています")
　　Else
　　　Call CopyPasteSUM(Target)
　　End If
　End If
End Sub

Private Function IsDoubling(TargetRange As Range, Target As Range) As Boolean
'TargetRange内にTargetと重複する値が存在するか確認。
　'空白だった場合、falseを返して終了
　If IsEmpty(Target) Then
　　IsDoubling = False
　　Exit Function
　End If
　Dim myCell As Range
　For Each myCell In TargetRange
　　'変更したセル以外に変更した値と同じ値があれば、trueを返して終了
　　If myCell.Address <> Target.Address And myCell.Value = Target.Value Then
　　　IsDoubling = True
　　　Exit Function
　　End If
　Next myCell
　'上記にヒットしない=重複がなければfalseを返す
　IsDoubling = False
End Function
******************************
**********標準モジュール********************
Sub CopyPasteSUM(Target As Range)
'集計マクロ
　'開いているブックの中から指定の名前のシートを検索する
　Dim SourceSheet As Worksheet
　Set SourceSheet = GetSourceSheet(Target.Value)
　'イベントを停止
　Application.EnableEvents = False
　'シート名を指定している場合、集計するシートから合計値を変数に格納
　Dim SourceValue(0 To 2) As Variant '<-適宜変更
　If Not SourceSheet Is Nothing Then
　　SourceValue(0) = SourceSheet.Range("A4").Value '<-適宜変更
　　SourceValue(1) = SourceSheet.Range("D9:G9").Value '<-適宜変更
　　SourceValue(2) = SourceSheet.Range("Q9:T9").Value '<-適宜変更
　End If
　'出力すべきまとめシートのセル範囲を設定。
　Dim PasteRange(0 To 2) As Range '<-適宜変更
　Set PasteRange(0) = Intersect(Target.EntireRow, Target.Parent.Range("C:C")) '<-適宜変更
　Set PasteRange(1) = Intersect(Target.EntireRow, Target.Parent.Range("D:G")) '<-適宜変更
　Set PasteRange(2) = Intersect(Target.EntireRow, Target.Parent.Range("M:P")) '<-適宜変更
　'合計値をまとめシートに出力
　'シート名を指定していない場合、空白を出力=値をクリア
　Dim i As Integer
　For i = LBound(SourceValue) To UBound(PasteRange)
　　PasteRange(i).Value = SourceValue(i)
　Next i
　'イベントを再開
　Application.EnableEvents = True
End Sub

Private Function GetSourceSheet(SheetName As String) As Worksheet
'全てのシートの中から、指定のシート名のシートを返す。
　'指定シート名が空白なら、Nothingを返す。
　If SheetName = "" Then
　　Exit Function
　End If
　'開いているブックの中から指定シート名を探す
　Dim myBK As Workbook, myWS As Worksheet
　Dim ReturnSheet As Worksheet
　For Each myBK In Workbooks
　　For Each myWS In myBK.Worksheets
　　　If myWS.Name = SheetName Then
　　　　If Not ReturnSheet Is Nothing Then
　　　　　'シート名重複のエラーチェック
　　　　　MsgBox "指定のシート名が複数存在します。マクロを終了します。"
　　　　　End
　　　　Else
　　　　　Set ReturnSheet = myWS
　　　　End If
　　　End If
　　Next myWS
　Next myBK
　If ReturnSheet Is Nothing Then
　　'指定シートがない場合のエラーチェック
　　MsgBox "指定のシート名が存在しません。マクロを終了します。"
　　End
　Else
　　Set GetSourceSheet = ReturnSheet
　End If
End Function
******************************

お礼

Mathmi様

大変お世話になります。
度々お手数をお掛けしてしまい、申し訳ございませんでした。

あの後、帳票の仕様が一部変更になりましたが、
ご教示いただいたコードを一部変更することで、意図する動作ができるようになりました。
誠にありがとうございました。

今回作成のブックは『第一案』となり、
今後も継続して仕様改訂を行っていく予定です。

また改めて質問を掲載することがあるかと思いますが、
お時間許されましたら是非お知恵をお借りできましたら有難く存じます。
よろしくお願い申し上げます。

回答No.3

nishi6

A列の数値が気になりますし、B列には入力してはいけない行がありそうですが一応気にしないでコードを書いてみました。

このような処理には、
　・入力したシートがない場合の処理
　・既に入力したシート名を再度入力した場合の処理
は必須と思うので組み込んでみました。

また、各シートからまとめシートに転記した後にシート側に変更があったときの処理方法の決めも重要でしょう。

下記のコードは、まとめシートのコードウインドウに貼り付けます。
また、「Application.EnableEvents = False」を使ってイベントが発生しないようにしてあるので、動かしている最中に止まったりしたら、「Fukki」を動かして、イベントが発生するようにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim ws As Worksheet　　 '// ワークシート
　Dim wsSrc As Worksheet　'// ワークシート
　Application.EnableEvents = False
　If Target.Count = 1 And Target.Column = 2 Then
　　'// 重複入力チェック
　　If WorksheetFunction.CountIf( _
　　　　 Range("B10:B" & Range("B" & Rows.Count). _
　　　　　　　End(xlUp).Row), Target.Value) > 1 Then
　　　MsgBox "シート名：" & Target.Value & " は入力済みです"
　　　Target.Value = "": Target.Select　'// 戻る
　　　Application.EnableEvents = True
　　　Exit Sub
　　End If

　　For Each ws In ActiveWorkbook.Sheets
　　　'// シートの有無チェック
　　　If Target.Value = ws.Name Then
　　　　Set wsSrc = ws
　　　　With Target　　'// 転記と書式のセット
　　　　　.Range("B1") = wsSrc.Range("A4")
　　　　　.Range("C1:F1").Value = wsSrc.Range("D9:G9").Value
　　　　　.Range("L1:O1").Value = wsSrc.Range("Q9:T9").Value
　　　　　.Range("C1:F1", "L1:O1").NumberFormatLocal = "#,##0_ "
　　　　End With
　　　　Application.EnableEvents = True
　　　　Exit Sub
　　　End If
　　Next
　　'// シートなしのメッセージ
　　MsgBox "シート名：" & Target.Value & " はありません"
　　Target.Value = "": Target.Select　'// 戻る
　End If
　Application.EnableEvents = True
End Sub

Sub Fukki()
　Application.EnableEvents = True
End Sub

お礼

nishi6様

はじめまして。
お忙しい中、詳細までご教示いただきありがとうございました。

わたくしの勉強不足のせいで、お手配いただいたコードをうまく使いこなせませんでした。
大変申し訳ございません…。

今後、理解を深めて再度チャレンジする際に参考にさせていただきます。
まだまだ初心者ですので、またご相談させていただくかもしれませんが、その際は何卒よろしくお願いいたします。

回答No.2

Mathmi

No.1です。失礼、勘違いしていました。シート名が入力されているのはB列で、C列には会場名を転記するのですね。
修正しましたので、差し替えて下さい。
セル範囲の指定を修正しました。後、SouceValueに値を入れる時にvalueの指定を忘れていたので、明記しました。
また、まとめシートが別ブックだった場合にも対応しました。

＞明細のシートは余分な枚数を用意しておき、シートの増減がないように対応予定
との事ですが、このコードをに限って言うなら、シート数が増減しても問題ありません。

******************************
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim TargetRange As Range
　Set TargetRange = Range("B10:B69") '<-まとめシートのレイアウトにより適宜変更。

　'変更されたセルが一つだけでTargetRange内なら、集計マクロを起動する。
　If Target.Count = 1 And _
　 Not Intersect(Target, TargetRange) Is Nothing Then
　　Call CopyPasteSUM(Target)
　End If
End Sub
******************************
******************************
Option Explicit

Sub CopyPasteSUM(Target As Range)
　'指定した名称のシートが存在するか確認し、存在すれば変数に格納
　Dim myWS As Worksheet
　Dim SourceSheet As Worksheet
　For Each myWS In Workbooks("comatte2019.xls").Worksheets '<-適宜変更
　　If myWS.Name = Target.Value Then
　　　Set SourceSheet = myWS
　　　Exit For
　　End If
　Next myWS
　'変数に格納されていない=指定した名称のシートが存在しないなら終了する
　If SourceSheet Is Nothing Then
　　Exit Sub
　End If
　'イベントを停止
　Application.EnableEvents = False
　'集計するシートから合計値を変数に格納
　Dim SourceValue(0 To 2) As Variant '<-適宜変更
　SourceValue(0) = SourceSheet.Range("A4").Value '<-適宜変更
　SourceValue(1) = SourceSheet.Range("D9:G9").Value '<-適宜変更
　SourceValue(2) = SourceSheet.Range("Q9:T9").Value '<-適宜変更
　'出力すべきまとめシートのセル範囲を設定。
　Dim PasteRange(0 To 2) As Range '<-適宜変更
　Set PasteRange(0) = Intersect(Target.EntireRow, Target.Parent.Range("C:C")) '<-適宜変更
　Set PasteRange(1) = Intersect(Target.EntireRow, Target.Parent.Range("D:G")) '<-適宜変更
　Set PasteRange(2) = Intersect(Target.EntireRow, Target.Parent.Range("M:P")) '<-適宜変更
　'合計値をまとめシートに出力
　Dim i As Integer
　For i = LBound(SourceValue) To UBound(PasteRange)
　　PasteRange(i).Value = SourceValue(i)
　Next i
　'イベントを再開
　Application.EnableEvents = True
End Sub
******************************

補足

Mathmi様

はじめまして。
わかりやすいコードのご教示、誠にありがとうございました。
いただいたコードでクリアできました！
大変助かります！

そこで、ついでのようで大変恐縮なのですが・・・
追加で下記の２点について、改めてご教示いただけませんか。
度谷申し訳ありません…。

【 質問(1) 】
［まとめ］シートのB列（会場明細シート名）の既存値をクリアした場合、前の結果が残ったままになってしまうのですが、これを同時にクリアするようにはできますか？

【 質問(2) 】
ブック名を変更した場合、現状ではマクロのブック名の修正が必要かと思うのですが、これを自動対応するようにすることはできますか？

重ね重ね申し訳ございません。
よろしくお願いいたします。

回答No.1

Mathmi

セル指定がベタ打ちなので、あまり綺麗なコードではありませんが。

経費明細のシートと[まとめ]シートが同じブックにあるものとします。

[まとめ]シートのシートモジュールに以下のプロシージャを入れます。
******************************
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim TargetRange As Range
　Set TargetRange = Range("C10:C69") '<-まとめシートのレイアウトにより適宜変更。

　'変更されたセルが一つだけでTargetRange内なら、集計マクロを起動する。
　If Target.Count = 1 And _
　 Not Intersect(Target, TargetRange) Is Nothing Then
　　Call CopyPasteSUM(Target)
　End If
End Sub
******************************

標準モジュールに以下のプロシージャを入れます。
******************************
Option Explicit

Sub CopyPasteSUM(Target As Range)
　'指定した名称のシートが存在するか確認
　Dim myWS As Worksheet
　Dim myFlg As Boolean
　For Each myWS In Worksheets
　　If myWS.Name = Target.Value Then
　　　myFlg = True
　　　Exit For
　　End If
　Next myWS
　If Not myFlg Then
　　Exit Sub
　End If
　'集計する合計値があるシートを設定
　Dim SourceSheet As Worksheet
　Set SourceSheet = Worksheets(Target.Value)
　'イベントを停止
　Application.EnableEvents = False
　'集計するシートから合計値を変数に格納
　Dim SourceValue(0 To 1) As Variant '<-適宜変更
　SourceValue(0) = SourceSheet.Range("D9:G9") '<-適宜変更
　SourceValue(1) = SourceSheet.Range("Q9:T9") '<-適宜変更
　'出力すべきまとめシートのセル範囲を設定。
　Dim PasteRange(0 To 1) As Range '<-適宜変更
　Set PasteRange(0) = Intersect(Target.EntireRow, Target.Parent.Range("D:G")) '<-適宜変更
　Set PasteRange(1) = Intersect(Target.EntireRow, Target.Parent.Range("M:P")) '<-適宜変更
　'合計値をまとめシートに出力
　Dim i As Integer
　For i = LBound(SourceValue) To UBound(PasteRange)
　　PasteRange(i).Value = SourceValue(i)
　Next i
　'イベントを再開
　Application.EnableEvents = True
End Sub
******************************

これで、[まとめ]シートのC10:C69セルの内一つを明細のシート名に変更した場合、合計値がコピペされる筈です。
シートのレイアウトが変更になると修正が必要な行には「適宜変更」とコメントしてあります。