雑誌のバックナンバー検索を容易にするツール。送品予定表から作るエクセルVBAソフト

雑誌のバックナンバー検索の作業を超簡単にする方法があります。

それはVBAを使って送品予定表から作ることが出来ます。
過去のデータを探し出すのは面倒なものです。恐らく一度使えば手放せなくなります。

今回の雑誌バックナンバー検索シリーズの結論はこちらです。（作成方法に興味のない方はここで離脱いただけます。）これからこのダウンロード頂いた「雑誌バックナンバー検索.xlsm」について説明していきます。

エクセルVBAを使ってご自分で作れますので、もちろん使用料は無料になります。

これからの記事を読み進めて頂くと、改変可能なものも作ることができます。

ご自分でカスタマイズ可能なものが作れます。

＜このDLしたエクセルファイルはVBAコードを保護していますので改変はできません。＞

最終形のダウンロードはこちらから。

“雑誌バックナンバー検索ツール” をダウンロード BackNoKensaku.zip – 2188 回のダウンロード – 42 KB

このソフトはご自分で業務でお使いいただくのはフリーですが、

転載や転売については許可しておりませんので、ご使用にならないよう固くお断りいたします。

Sub 送品予定表転記()

 Dim mb As Object
 Dim wb As Object
 Dim mbp As Variant
 Dim fname As Variant
 Dim sname As Variant
  
 Application.ScreenUpdating = False

 Set mb = ThisWorkbook
 mbp = ThisWorkbook.Path
 fname = Dir(mbp & "\*.xls")

 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.Select
        sname = ActiveSheet.Range("B2")
        Selection.Copy _
        Destination:=mb.Worksheets(mb.Worksheets.Count).Range("A1")
        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 & "日分の送品予定表を取り込みました。"
 
 End Sub

Sub データをまとめる()
 Dim Ws As Worksheet, Wsa As Worksheet
 Dim sR As Long, saR As Long

 Set Wsa = 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
 
 NextApplication.CutCopyMode = False

Worksheets("データまとめ").SelectWith Range("A1").CurrentRegion
.Borders.LineStyle = xlLineStyleNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlHairline
End With

シート体裁

 End Sub

Sub シート体裁()
    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 Sub

Sub 送品予定表削除()

 Dim Wsb As Worksheet
 
 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
 
End Sub

Sub データまとめクリア()

    Worksheets("データまとめ").Cells.Clear
    With Worksheets("データまとめ")
        .Cells.UseStandardHeight = True
        .Cells.UseStandardWidth = True
    End With

End Sub