VBAの基本操作（応用１）

　今回は今までの記事の内容を踏まえてちょこっと本格的なコードを紹介したいと思います。

＜フォルダの中身＞

＜ファイルの中身＞

　こんな感じでフォルダの中に注文書の一覧があった場合にそれぞれ必要なデータを抽出し、整理するといったことをやっていきたいと思います。

Sub test()
    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ""
        If .Show = True Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Dim fso As Object
    Dim file As Object
    Dim str1 As Variant
    Dim str2 As Variant
    Dim str3 As Variant
    Dim str4 As Variant
    Dim SetFile As String
    Dim wbMoto, wbSaki As Workbook
    Dim j As Long
    Dim W As Long
    Dim Buf As Long
    Dim ex  As New Excel.Application
    Dim wb As Workbook

    Buf = 0  '最大小計
    SunX = 0 'ブックごとの合計数量
    SunY = 0 'ブックごとの合計金額

    Set wbMoto = ActiveWorkbook
    Application.DisplayAlerts = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim BaseNames(fso.getFolder(folderPath).Files.Count)


    For Each file In fso.getFolder(folderPath).Files
        cnt = cnt + 1
        BaseNames(cnt) = fso.GetBaseName(file.Name)

        '項目の表示
        Range("A1") = "発注番号"
        Range("B1") = "発注者"
        Range("C1") = "発注先"
        Range("D1") = "小計最大品名"
        Range("E1") = "小計最大価格"
        Range("F1") = "数量合計"
        Range("G1") = "金額合計"

            '発注ナンバーと発注者の抽出
            str1 = Split(BaseNames(cnt), "注文書")
            Cells(cnt + 1, 1) = Mid(str1(1), 1, 6)
            str2 = Split(str1(1), "(")
            str3 = Split(str2(1), ")")
            str4 = Split(str3(0), "2")
            Cells(cnt + 1, 2) = Split(str4(0), "2")       

            '発注先の抽出
            SetFile = folderPath & "\" & BaseNames(cnt)
            Set wb = ex.Workbooks.Open(Filename:=SetFile, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
                wb.Worksheets(1).Range("A6").Copy
                wbMoto.Worksheets(1).Cells(cnt + 1, 3).PasteSpecial xlPasteFormulasAndNumberFormats
                Application.CutCopyMode = False

             '最大小計の品目抽出
            For j = 12 To 26
                If Buf < wb.Worksheets(1).Cells(j, 5) Then
                    Buf = wb.Worksheets(1).Cells(j, 5)
                End If
            Next j

            '最大小計（金額）のコピー
            wbMoto.Worksheets(1).Cells(cnt + 1, 5) = Buf

            '最大小計（品目）のコピー
            For j = 12 To 26
                If wb.Worksheets(1).Cells(j, 5) = Buf Then
                    wbMoto.Worksheets(1).Cells(cnt + 1, 4) = wb.Worksheets(1).Cells(j, 1)
                End If
            Next j

            Buf = 0

            '数量の合計
            For K = 12 To 26
                SunX = SunX + wb.Worksheets(1).Cells(K, 2)
            Next K
            wbMoto.Worksheets(1).Cells(cnt + 1, 6) = SunX
            SunX = 0


            '金額の合計
            For W = 12 To 26
                SunY = SunY + wb.Worksheets(1).Cells(W, 5)
            Next W
            wbMoto.Worksheets(1).Cells(cnt + 1, 7) = SunY
            SunY = 0

            'ブックを閉じる
            'wbSaki.Close False

            'ブックを閉じる
            Call wb.Close

            'Excelアプリケーションを閉じる
            Call ex.Application.Quit
    Next

    Range("E2 : E51").NumberFormatLocal = "#,###"
    Range("G2 : G61").NumberFormatLocal = "#,###"
End Sub

＜動作結果＞

　こんな感じになります。それでは難しい部分を分けて説明します。

フォルダの指定とファイルの判定

    'フォルダパスの変数設定
    Dim folderPath As String

    'FileDaialogによるフォルダの指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ""

        If .Show = True Then   'ファイルがあった場合
            folderPath = .SelectedItems(1)
        Else   'ファイルがなかった場合
            Exit Sub
        End If
    End With

選択したファイルへの設定

    '選択中のファイルを「wbMotp」とする
    Set wbMoto = ActiveWorkbook

    '確認メッセージを開かなくする
    Application.DisplayAlerts = False

    'fsoの設定
    Set fso = CreateObject("Scripting.FileSystemObject")

    'ベースネームを配列変数に設定
    ReDim BaseNames(fso.getFolder(folderPath).Files.Count)

　ReDimを使っていますがこれは処理の中で変数を増やしたい場合に使用します。今回の場合はBaseName(1),BaseName(2),BaseName(3)と増やしていくことが出来ます。

フォルダパスの設定

    'フォルダ内のファイルへとパスを繋ぐ
    For Each file In fso.getFolder(folderPath).Files

        cnt = cnt + 1

        'ベースネームにファイル名を割り当てる
        BaseNames(cnt) = fso.GetBaseName(file.Name)

発注ナンバーと発注者の抽出

            str1 = Split(BaseNames(cnt), "注文書")

            '発注ナンバーをセルへ表示
            Cells(cnt + 1, 1) = Mid(str1(1), 1, 6)

　　　　　　　'残った文字列から不要な情報を取り除く
            str2 = Split(str1(1), "(")
            str3 = Split(str2(1), ")")
            str4 = Split(str3(0), "2")

           '発注者をセルへ表示
            Cells(cnt + 1, 2) = Split(str4(0), "2")

このコードではBaseNames(cnt)はファイル名をそのまま値として入っているのでいらない情報を取り除いています。

発注先の抽出

            'フォルダパスとファイル名を足すことでファイルパスを設定する
            SetFile = folderPath & "\" & BaseNames(cnt)

            '選択中のワークブックを開く（厳密には開かないで中身を参照する）
            Set wb = ex.Workbooks.Open(Filename:=SetFile, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)

                '発注先をコピーする
                wb.Worksheets(1).Range("A6").Copy

                '発注先を張り付ける
                wbMoto.Worksheets(1).Cells(cnt + 1, 3).PasteSpecial xlPasteFormulasAndNumberFormats

                'コピーした内容を空に戻す
                Application.CutCopyMode = False

Dim ex As New Excel.Application
ex.Workbooks.Open(...)
　この二つの構文によって新しく開くファイルをエクセルとして扱うよう設定します。

ReadOnly:=True, IgnoreReadOnlyRecommended:=True
　このコードによって開くエクセルデータをリードオンリー[読み取り専用]に設定します。
　※メリット：ファイルを開くことなく中身を参照できるのでとても処理が早くなる
　※デメリット：開いたファイルの中身の編集はできない

[最大小計の算出]

最大小計の抽出

           Dim Buf As Long 　'Bufは最大小計を入れるオブジェクト

　　　　　　　'最大小計を算出する範囲
            For j = 12 To 26

　　　　　　　　　'もしBuf(最大小計)の値よりセルの値が大きい場合
                If Buf < wb.Worksheets(1).Cells(j, 5) Then

　　　　　　　　　　　'Bufの値を更新する(セルの値が入る)
                    Buf = wb.Worksheets(1).Cells(j, 5)
                End If
            Next j

            '集計用のシートに最大小計（金額）を入力する
            wbMoto.Worksheets(1).Cells(cnt + 1, 5) = Buf

            '集計用のシートに最大小計（品目）を入力する
            For j = 12 To 26
                If wb.Worksheets(1).Cells(j, 5) = Buf Then

　　　　　　　　　　　'最大小計のセルのA列（品目）の値を入れる
                    wbMoto.Worksheets(1).Cells(cnt + 1, 4) = wb.Worksheets(1).Cells(j, 1)
                End If
            Next j

　　　　　　　'最大小計の値を初期化する（次の注文書でもBufを使用するため）
            Buf = 0

金額の表示を整える

    Range("E2 : E51").NumberFormatLocal = "#,###"
    Range("G2 : G61").NumberFormatLocal = "#,###"

それではVBAの基本操作（応用２）へ続きます！