雑誌バックナンバー検索に送品データを編集し利用する

Option Explicit

Sub 送品予定表転記()
    Dim mb As Workbook
    Dim wb As Workbook
    Dim mbp As Variant
    Dim fname As Variant
    Dim sname As Variant
    Dim n As Long
        Application.ScreenUpdating = False
        Set mb = ThisWorkbook
        mbp = ThisWorkbook.Path
        fname = Dir(mbp & "\*.xls")
        n = 0
        Do Until fname = Empty
           If fname <> mb.Name Then
               Worksheets.Add after:=mb.Worksheets(mb.Worksheets.Count)
               Set wb = Workbooks.Open(mbp & "\" & fname)
               wb.ActiveSheet.Cells.Copy _
                   Destination:=mb.Worksheets(mb.Worksheets.Count).Range("A1")
               sname = wb.ActiveSheet.Range("B2")
               mb.Worksheets(mb.Worksheets.Count).Name = sname
               wb.Close (False)
               n = n + 1
               Range("A1").Select
           End If
           fname = Dir
        Loop
        Application.ScreenUpdating = True
        Worksheets("検索結果").Select
        Range("A1").Select
        MsgBox n & "日分の送品予定表を取り込みました。", vbInformation, _
                    "雑誌バックナンバー検索"
End Sub

Sub データをまとめる()
    Dim mb As Workbook
    Dim Ws, Wsa As Worksheet
    Dim sR, saR As Long
        Set mb = ThisWorkbook
        Set Wsa = mb.Worksheets("データまとめ")
        For Each Ws In Worksheets
            If Ws.Name <> "データまとめ" Or Ws.Name <> "検索結果" _
               Or Ws.Name <> "メモ" Then
               sR = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
               saR = Wsa.Cells(Wsa.Rows.Count, 1).End(xlUp).Row + 1
                If Wsa.Range("A2") = "" Then
                   saR = 1
                   Ws.Rows("1:" & sR).Copy Destination:=Wsa.Rows(saR)
                Else
                   Ws.Rows("2:" & sR).Copy Destination:=Wsa.Rows(saR)
                End If
            End If
        Next
        Application.CutCopyMode = False
        Worksheets("データまとめ").Select
        With Range("A1").CurrentRegion
           .Borders.LineStyle = xlLineStyleNone
           .Borders.LineStyle = xlContinuous
           .Borders.Weight = xlHairline
        End With
        Call Module1.シート体裁
        MsgBox "データまとめを完了しました", vbInformation, _
                    "雑誌バックナンバー検索"
 End Sub

Sub シート体裁()
    Dim mb As Workbook
        Set mb = ThisWorkbook
        With mb.Worksheets("検索結果")
            .Range("A:L").Font.Size = 9
            .Range("A:A").ColumnWidth = 4
            .Range("B:B").ColumnWidth = 8
            .Range("C:C").ColumnWidth = 10
            .Range("D:D").ColumnWidth = 8
            .Range("E:F").ColumnWidth = 4
            .Range("G:G").ColumnWidth = 3
            .Range("H:H").ColumnWidth = 11
            .Range("I:I").ColumnWidth = 21
            .Range("J:J").ColumnWidth = 7
            .Range("K:K").ColumnWidth = 6
            .Range("L:L").ColumnWidth = 6
        End With
        Range("A1").Select
End Sub

Sub 送品予定表削除()
    Dim Wsb As Worksheet
        ThisWorkbook.Activate
        Application.DisplayAlerts = False
        For Each Wsb In Worksheets
           If Wsb.Name <> "データまとめ" And Wsb.Name <> "検索結果" _
               And Wsb.Name <> "メモ" Then
               Wsb.Delete
           End If
        Next
        Application.DisplayAlerts = True
        MsgBox "送品予定表を削除しました", vbInformation, _
                    "雑誌バックナンバー検索"
End Sub

Sub データまとめクリア()
    Dim mb As Workbook
        Set mb = ThisWorkbook
           With mb.Worksheets("データまとめ")
               .Cells.Clear
               .Cells.UseStandardHeight = True
               .Cells.UseStandardWidth = True
           End With
        MsgBox "データまとめをクリアしました", vbInformation, _
                    "雑誌バックナンバー検索"
End Sub