Dim Rst As VbMsgBoxResult
Sub 確認_複数ブックを1ブックに()
'########################
'# 複数のブックを1つのブックにまとめます
'#
'########################
Rst = MsgBox("このブックと同じフォルダにあるファイルをシートとして追加します。" & vbCrLf & _
"同盟のシートを上書きする場合は「はい」・追加する場合は「いいえ」を押してください。実行しますか?", _
vbYesNoCancel + vbQuestion + vbDefaultButton3, _
"複数ブックを1ブックにまとめる")
If Rst = vbCancel Then
Exit Sub
Else
複数ブックを1ブックに
End If
End Sub
Sub 複数ブックを1ブックに()
'########################
'# 複数のブックを1つのブックにまとめます
'#
'########################
Dim mb As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim sws As Worksheet
Dim myfdr As String
Dim fname As String
Dim n As Integer
Dim Pwd As String
Pwd = InputBox("全ファイルに共通のパスワードを設定している場合、" & vbCrLf & _
"【パスワード】を入力してください" & vbCrLf & _
"パスワードなし、異なるパスワードの場合は空欄のままOKを押してください")
Application.ScreenUpdating = False
Set mb = ActiveWorkbook '###このコピー先ブックをmbとする
myfdr = ActiveWorkbook.Path
fname = Dir(myfdr & "\*.xls*") 'フォルダ内のexcelブックを検索
i = 1
Do Until fname = Empty 'すべて検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(Filename:=myfdr & "\" & fname, UpdateLinks:=0, Password:=Pwd)
'そのブックを開きwbとする
On Error Resume Next
For Each ws In wb.Worksheets 'コピー元ブックのシートws全部
Set cws = mb.Worksheets(ws.Name) 'コピー先ブックmbのシートン名がコピー元wsと同じものをcwsにする
If Not cws Is Nothing Then 'コピー元とコピー先に同じシート名があったら
If Rst = vbYes Then 'シートの上書きOKなら
Application.DisplayAlerts = False
mb.Worksheets(ws.Name).Delete 'コピー先のシートを削除
Application.DisplayAlerts = True
Else
wb.Worksheets(ws.Name) = wb.Worksheets(ws.Name) & i 'コピー元ブックのシートwsの名前に数字をつける
'名前の定義は消してしまう
With wb.Worksheets(ws.Name)
DeleteDefinedNames
End With
i = i + 1
End If
End If
ws.Copy after:=mb.Sheets(mb.Sheets.Count) 'コピー元wsをコピー先mbにコピー、ブックの末尾に置く
Next
On Error GoTo 0
wb.Close savechanges:=False 'コピー元wbを閉じる
n = n + 1
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop
Application.ScreenUpdating = True
ActiveWorkbook.Save
MsgBox n & "件のブックをコピーしました"
End Sub