Excel VBAと出会ったきっかけ

本記事のコードはExcel2013で記述しています。

はじめに

私の業務の中には最大級に面倒くさいタスクがありました。
それが、管理図¹作成と管理図へのデータ転記。

私の部署の管理図(Excelファイル)では、
報告書ファイルの項目リスト数に合わせて、数値データを転記するメインシートとグラフシートで構成され、グラフシートは項目リスト数分のシートを作成する必要がありました。

つまり、項目リストが100個あれば100ページ作成。
いや、えぐいてー！（霜降り粗品）

グラフシート作成はフォーマットページをひたすらコピペ。
シート名はシート毎に違うため、(これ意味あるのか？と思いつつ)全シートの名前を手入力で変更、これがきつい、、。
しかも作成頻度が高い。

この非生産的な作業をどうにかできないかと書店でExcel関連の本を読み漁り、
そこで出会ったのが**"Excel VBA"**でした。

環境/使用言語

• Windows 10
• Excel2013
• Excel VBA

処理内容

事前準備：管理図のマスターファイルを作成
＜簡単なプログラムの流れ＞
1.ユーザーが報告書を選択
2.選択した報告書の必要情報を配列で取得
3.報告書のリスト項目数に応じて、マスターから管理図を作成
4.特定のフォルダに作成日付等を指定して保存

汚いコードだったので、最近書き直しました。
最初からこれが書けたわけではありません（笑）

CreateChart

    MsgBox "報告書ファイルを選択してください。"

    Dim ReportPath As String
    ReportPath = "報告書フォルダパス"
    
    With Application.FileDialog(msoFileDialogFilePicker)
            .Filters.Clear
            .AllowMultiSelect = False
            .InitialFileName = ReportPath
            .Filters.Add Description:="ExcelかCSVのファイル", Extensions:="*.xls* ; *.xlsm"
        If Not .Show Then Exit Sub
            Dim strOpenFile As String
            strOpenFile = .SelectedItems(1)
    End With
    
    Dim ReportBook As Workbook, ReportWs As Worksheet
    Set ReportBook = Workbooks.Open(strOpenFile)
    Set ReportWs = ReportBook.Worksheets("シート名")
    
    With ReportWs
    
        Dim str As String, HeadNumber As String
        str = ReportBook.Name
        HeadNumber = Left(str, InStr(str, ".") - 1)
        
        '報告書ファイルの必須情報を取得
        Dim PartNumber As String, PartName As String, SupplierName As String

        PartNumber = .Range("D13")
        PartName = .Range("D14")
        SupplierName = .Range("D15")
        
        Dim StartRow As Long, PublicColumn As Long, MaxRow As Long, ListCount As Long, ListSum As Long
        Dim i As Long, p As Long 'pはページを示す

        '1P
        StartRow = .Range("U28").Row
        PublicColumn = .Range("U28").Column
        MaxRow = .Range("U28").End(xlDown).Row
    
        ListCount = MaxRow - StartRow + 1
                
        Const RowMax = 38
        Dim Number() As String, List() As String, Standard() As String, Tool() As String
        ReDim Number(1 To RowMax), List(1 To RowMax), Standard(1 To RowMax), Tool(1 To RowMax)
  
        p = 1
        For i = 1 To ListCount
            
            Number(i) = .Cells(StartRow + i - 1, 1)
            List(i) = .Cells(StartRow + i - 1, 2)
            Standard(i) = .Cells(StartRow + i - 1, 3)
            Tool(i) = .Cells(StartRow + i - 1, 18)

        Next i
        ListSum = ListCount
   
        '2P以降にデータがある場合の処理
        If Not .Range("U57") = "" Then

            Const d = 45 '公差
            p = 2
            Do While .Cells(d * p - 33, PublicColumn) <> ""
            
                StartRow = d * p - 33   '等差数列 x=57,102,...(i=2 To)
                MaxRow = .Cells(StartRow, PublicColumn).End(xlDown).Row
                ListCount = MaxRow - StartRow + 1
                
                ReDim Preserve Number(1 To ListSum + ListCount), List(1 To ListSum + ListCount)
                ReDim Preserve Standard(1 To ListSum + ListCount), Tool(1 To ListSum + ListCount)
                
                For i = 1 To ListCount
                    Number(i + ListSum) = .Cells(StartRow + i - 1, 1)
                    List(i + ListSum) = .Cells(StartRow + i - 1, 2)
                    Standard(i + ListSum) = .Cells(StartRow + i - 1, 3)
                    Tool(i + ListSum) = .Cells(StartRow + i - 1, 18)
                Next i
                
                ListSum = ListSum + ListCount   '複数ページのリスト項目合計
                
            p = p + 1
            Loop
        End If
    End With 'ReportWs

    ReportBook.Close
    
    Set ReportWs = Nothing
    Set ReportBook = Nothing
    
    'マスターファイルを指定フォルダに名前を変更して複製する
    Dim MasterFilePath As String, SaveFolderName As String, SaveFolderPath As String, NewFileName As String, NewFile As String
    
        MasterFilePath = "マスターファイルパス"
        SaveFolderName = "管理図作成"
        SaveFolderPath = ReportPath & "\" & SaveFolderName
        NewFileName = HeadNumber & "." & PartName & "_" & PartNumber & ".xlsm"
        NewFile = SaveFolderPath & "\" & NewFileName
        
    Call CopyFile1(MasterFilePath, SaveFolderPath, NewFileName)
    
    Dim ChartBook As Workbook, ChartWs As Worksheet
    Set ChartBook = Workbooks.Open(NewFile)
    Set ChartWs = ChartBook.Worksheets("シート名")
    
    With ChartWs
        .Activate
        .Range("A4:K14").Copy

        For i = 1 To ListSum - 1
            .Cells(13 * i + 4, 1).Select
            .Paste
        Next i
        
        '取得情報を転記
        .Range("A1") = PartName
        .Range("A2") = PartNumber

        For i = 1 To ListSum
            .Cells(13 * i - 13 + 4, 1) = Number(i) & "." & List(i) & "(" & Standard(i) & ")"
            .Cells(13 * i - 13 + 5, 1) = Tool(i)
        Next i
    End With 'ChartWs

    With ChartBook
        .Worksheets(3).Activate
        'シートの複製
        For i = 1 To ListSum - 1
            .Worksheets(3).Copy after:=.Sheets(.Sheets.Count)
        Next i

        'シート名等の変更
        For i = 1 To ListSum
            .Worksheets(i + 2).Range("A1") = PartName
            .Worksheets(i + 2).Name = Number(i) & "." & List(i)
            .Worksheets(i + 2).Range("A2") = Number(i) & "." & List(i) & "(" & Standard(i) & ")"
            .Worksheets(i + 2).Range("E2") = Tool(i)
        Next i

    End With 'ChartWs

    ChartWs.Activate

    'A列の整地
    With ChartWs.Columns("A:A")
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
    End With
    
    ChartWs.Cells(3, 2).Activate
    
    ChartBook.Save
    ChartBook.Close
    
    Set ChartWs = Nothing
    Set ChartBook = Nothing

    MsgBox "「" & HeadNumber & "." & PartName & "_" & PartNumber & "」を作成しました。"

    Shell "C:\Windows\Explorer.exe " & SaveFolderPath

'マスターを複製してセーブフォルダに名前を変更して保存する定義関数
Private Function CopyFile1(ByVal Master As String, ByVal NewSaveFolder As String, ByVal NewFile As String)
            
    'フォルダがなければ作成する
    If Dir(NewSaveFolder, vbDirectory) = "" Then
        MkDir NewSaveFolder
    End If
    
    Dim NewPath As String
        NewPath = NewSaveFolder & "\" & NewFile            

    FileCopy Master, NewPath
        
End Function

今回はコードだけ記録しておきます。
時間ができたら、もう少し細分化して解説した記事に更新したいと思います。

追加：AccessからExcel操作する方法の記事で本記事のマクロをAccessから操作する記事を投稿しています。

1. 管理図とは、製品の品質管理において製造工程が安定しているかを判断するために品質のばらつきを分析・管理するためのグラフ。 ↩