他のbookの票を集計する

質問

お知恵をお貸しください！

フォルダー「テスト」の中に保護のかかったエクセルのファイルが50個位入っています。
このファイルの中のsheet3にある表（A2：E25)をすべてコピーして集計用の１ファイルにまとめたいと思っています。

集計用のファイルからマクロで全ファイルの保護を外してコピー、再び保護をかける。
コピーしたものを1ファイルにまとめる（元の票が参照式ばかりなので形式を選択して値のみの貼り付け）。

このよう事は可能でしょうか？

回答No.2

MSZ006

集計の仕方が分かりませんので、集計ファイルのsheet1に、縦にずらっとコピーするとして、下記でどうでしょうか？
summary()を実行してください。
なお集計用ファイルも同じフォルダに入れておいてください。
-------------------------------

Option Explicit
Private filename() As String
Private cnt As Long

Sub summary()
Application.ScreenUpdating = False
GetFileName
CopySheet
Application.ScreenUpdating = True
End Sub

Private Sub GetFileName() 'ファイル名一覧取得
Dim str As String
Dim i As Long
Dim path As String
Dim thisbook As String

path = ThisWorkbook.path + "\"
thisbook = ThisWorkbook.Name

str = Dir(path & "*.xls")
cnt = 1
Do While str <> ""
If str <> thisbook Then
ReDim Preserve filename(cnt)
filename(cnt) = str
Else
cnt = cnt - 1
End If
cnt = cnt + 1
str = Dir()
Loop
ReDim Preserve filename(cnt)
filename(cnt) = ""

End Sub

Private Sub CopySheet() '各シートの指定範囲を集計のsheet1にコピー
Dim str As String
Dim i As Long

Dim s_ws As Worksheet
Dim m_ws As Worksheet
Dim m_wb As Workbook
Dim Obj As Object

i = 1
Set s_ws = Workbooks(ThisWorkbook.Name).Worksheets("Sheet1")
Application.DisplayAlerts = False

str = ThisWorkbook.path + "\" + filename(i) 'コピー元ファイル名フルパス

Do While str <> ThisWorkbook.path + "\"
Set m_wb = Workbooks.Open(str)
Set m_ws = m_wb.Worksheets("sheet3")

m_ws.Range("A2:E25").Select
Selection.Copy
s_ws.Range(s_ws.Cells(i * 24 - 23, 1), s_ws.Cells(i * 24 - 23, 1)).PasteSpecial Paste:=xlPasteValues 'ペースト
m_wb.Close

i = i + 1
str = ThisWorkbook.path + "\" + filename(i) 'コピー元ファイル名フルパス
Loop

s_ws.Range("A1").Select
Application.DisplayAlerts = True

End Sub

回答No.1

play_with_you

可能です。