ブックの統合について

質問

Sub 集計()
Application.ScreenUpdating = False
fldPath = ThisWorkbook.Path & "\"
fname = Dir(fldPath & "*.xls")
Do Until fname = Empty
If fname <> ThisWorkbook.Name Then
Workbooks.Open fldPath & fname
mx = Application.WorksheetFunction.Max(Sheets("1日").Columns(1))
lr = Sheets("1日").Range("B65536").End(xlUp).Row
FR = ThisWorkbook.Sheets("1日").Range("B65536").End(xlUp).Row + 1
Sheets("1日").Rows("6:" & lr).Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close (False)
Application.DisplayAlerts = True
ThisWorkbook.Sheets("1日").Cells(FR, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
fname = Dir
Loop
Application.ScreenUpdating = True
End Sub

上記のようにマクロを組みましたが、集計したいシートがたくさんある為
シートごとにマクロを組みなおさなければなりません。
そこで、
集計するシートと集計されるシートのシート名が一緒の時、
わざわざsheets("1日")と書き直さなくても
"Activesheetと同じシート名"のようなマクロの組み方は出来るのでしょうか。

回答No.1

hana-hana3 · ベストアンサー

＞集計するシートと集計されるシートのシート名が一緒の時、わざわざsheets("1日")と書き直さなくても

この集計シートの関係がどうなっているか解りませんが、

例え、シート名が同一であっても、ブック名から明記すれば問題無くマクロを動かす事が可能です。
マクロ動作中にどのブック（やシート）がアクティブになるかをしっかりと把握しながらマクロを書かないと混乱する事になりますから、ブック名やシート名を明記するような記述方法を癖にした方が誤動作防止面だけでなく可読性も高まります。

ThisWorkbook.Sheets("sheet1")
Workbooks("Book1").Sheets("sheet1")
Workbooks("Hoge1").Sheets("sheet1")

＞"Activesheetと同じシート名"のようなマクロの組み方は出来るのでしょうか。

マクロでシート名を取得出来ます。

WsName = ThisWorkbook.ActiveSheet.Name '変数にシート名取得する。
Workbooks("Book1").Sheets(WsName).Activate ' 変数 WsName と同名シートをアクティブにする。

２行を一緒にすると、こんな書き方も。
Workbooks("Book1").Sheets(ThisWorkbook.ActiveSheet.Name).Activate

動作テストはしていませんが、修正してみました。
----------------------------------------------------------
Sub 集計2()

Dim TmpBook As Workbook
Dim WsName As String

Application.ScreenUpdating = False

fldPath = ThisWorkbook.Path & "\"
fname = Dir(fldPath & "*.xls")

WsName = ThisWorkbook.ActiveSheet.Name

Do Until fname = Empty

If fname <> MyBook.Name Then

Workbooks.Open fldPath & fname
Set TmpBook = Workbooks(fname)

With TmpBook.Sheets(WsName)
mx = Application.WorksheetFunction.Max(.Columns(1))
lr = .Range("B65536").End(xlUp).Row
.Rows("6:" & lr).Copy
End With

Application.DisplayAlerts = False
TmpBook.Close
Application.DisplayAlerts = True

FR = ThisWorkbook.Sheets("1日").Range("B65536").End(xlUp).Row + 1
ThisWorkbook.Sheets(WsName).Cells(FR, 1).Paste

Application.CutCopyMode = False

End If

fname = Dir

Loop

Application.ScreenUpdating = True

End Sub