2018年10月4日木曜日

複数ブック系

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