VBA課題006「注文書をデータ取込」回答コード

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて毎月出題される、
VBAの問題に対する私の回答ソースコードを掲載いたします。

今回掲載するコードは本ブログの基本問題集#2としても出題していた、
「注文書をデータ取込」問題です。

今回も読みやすさ重視で書いてみましたので、
よろしければご参考ください(´∀｀)

課題の内容

今回は注文書ファイルの内容をデータシートへ取り込むシンプルなお題です。

詳細は下記リンク内にある「課題説明」シートをご確認ください。

せっかくなので回答を見る前に皆さんも挑戦してみましょう。

一度自分が作ってから他の人のコードを見ることで、
学習効果が何倍にも高まります。

完成させなくても、出来る範囲で解くだけでも十分効果がありますので、
是非ともトライしてみてください！

◇ 「領収書PDFを出力」の課題ファイルはこちら
Discord：★出題【VBA】#006 注文書をデータ取込

◇ 「領収書PDFを出力」への回答集はこちら
Discord：☆回答【VBA】#006 注文書をデータ取込

※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

課題の回答ファイル

実際の回答ファイルはこちらをご覧ください。
(和風スパ)【VBA】006_注文書をデータ取込.xlsm

ソースコード

標準モジュール:Df_シートレイアウト

Option Explicit

' 販売データ
Public Const Adrs販売データ_年度 = "F2"
Public Const R1st販売データ = 5
Public Const C1st販売データ = 2
Public Enum CNo販売データ
    No = C1st販売データ
    購入者
    月
    日
    品物
    価格
    個数
    売上
    取込日
End Enum
Public Const CLast販売データ = CNo販売データ.取込日

' 注文書
Public Const Adrs注文書_購入者 = "C5"
Public Const Adrs注文書_注文日 = "C7"
Public Const Adrs注文書_合計税別 = "F22"
Public Const Adrs注文書_消費税 = "F23"
Public Const Adrs注文書_合計税込 = "F24"
Public Const R1st注文書 = 12
Public Const RLast注文書 = 21
Public Const C1st注文書 = 2
Public Enum CNo注文書
    No = C1st注文書
    品物
    価格
    個数
    金額
End Enum
Public Const CLast注文書 = CNo注文書.金額

' 実行シート
Public Const Adrs実行シート_ファイルパス = "C4"
Public Const Adrs実行シート_フォルダパス = "C9"
Public Const R1st取込ログ = 12
Public Const C1st取込ログ = 2
Public Enum CNo取込ログ
    No = C1st取込ログ
    取込ファイル名
    結果
End Enum
Public Const CLast取込ログ = CNo取込ログ.結果


Function Is注文書シート(判定シート As Worksheet) As Boolean
    Is注文書シート = 判定シート.Range("B2") = "注　　文　　書" _
                 And 判定シート.Range("D24") = "合計(税込)"
End Function

標準モジュール:Pr0_注文書取込_共通コード

Option Explicit

' 注文書 → 販売データ
Sub 指定の注文書シートを販売データに取り込む(ws注文書 As Worksheet)

    ' 出力第1行(最終行+1)と出力No(最大値+1)を取得
    Dim R_出力 As Long: R_出力 = Get最終行(WS販売データ) + 1
    Dim 出力No As Long: 出力No = WorksheetFunction.Max(WS販売データ.Columns(CNo販売データ.No)) + 1
    
    ' 注文書の表部分をループ
    Dim R_取込 As Long
    For R_取込 = R1st注文書 To RLast注文書
    
        ' 金額が0でない行を取込
        If ws注文書.Cells(R_取込, CNo注文書.金額) <> 0 Then

            WS販売データ.Cells(R_出力, CNo販売データ.No) = 出力No
            WS販売データ.Cells(R_出力, CNo販売データ.購入者) = ws注文書.Range(Adrs注文書_購入者)
            WS販売データ.Cells(R_出力, CNo販売データ.月) = Month(ws注文書.Range(Adrs注文書_注文日))
            WS販売データ.Cells(R_出力, CNo販売データ.日) = Day(ws注文書.Range(Adrs注文書_注文日))
            WS販売データ.Cells(R_出力, CNo販売データ.品物) = ws注文書.Cells(R_取込, CNo注文書.品物)
            WS販売データ.Cells(R_出力, CNo販売データ.価格) = ws注文書.Cells(R_取込, CNo注文書.価格)
            WS販売データ.Cells(R_出力, CNo販売データ.個数) = ws注文書.Cells(R_取込, CNo注文書.個数)
            WS販売データ.Cells(R_出力, CNo販売データ.売上) = ws注文書.Cells(R_取込, CNo注文書.金額)
            WS販売データ.Cells(R_出力, CNo販売データ.取込日) = Date
            
            ' 出力行とNoを更新
            R_出力 = R_出力 + 1
            出力No = 出力No + 1
            
        End If
    
    Next ' 注文書の表部分をループ


End Sub

' 取込済判定(同日同購入者で判定)
Function Is指定注文書が販売データに取込済(ws注文書 As Worksheet) As Boolean
    
    ' そもそも年度が異なればExit
    If WS販売データ.Range(Adrs販売データ_年度) <> Get年度(ws注文書.Range(Adrs注文書_注文日)) Then Exit Function
    
    ' 判定キーの取得
    Dim key月 As Long: key月 = Month(ws注文書.Range(Adrs注文書_注文日))
    Dim key日 As Long: key日 = Day(ws注文書.Range(Adrs注文書_注文日))
    Dim key購入者 As String: key購入者 = ws注文書.Range(Adrs注文書_購入者)
    
    ' 全キーが一致するデータがあるか判定
    Dim R As Long
    For R = R1st販売データ To Get最終行(WS販売データ)
    
        If WS販売データ.Cells(R, CNo販売データ.月) = key月 _
        And WS販売データ.Cells(R, CNo販売データ.日) = key日 _
        And WS販売データ.Cells(R, CNo販売データ.購入者) = key購入者 Then
            Is指定注文書が販売データに取込済 = True
            Exit Function
        End If
    
    Next
    
End Function

標準モジュール:Pr1_注文書取込_ファイル指定

Option Explicit

' マクロ① 指定パスの注文書を取込
Sub 指定した注文書ファイルを販売データに取り込む()

    ' 取込ファイルの存在・ファイル形式チェック
    Dim path取込ファイル As String: path取込ファイル = WS実行シート.Range(Adrs実行シート_ファイルパス)
    Dim 取込ファイル名 As String: 取込ファイル名 = FSO.GetFileName(path取込ファイル)
    
    If 取込ファイル名 = "" Then MsgBox "指定したファイルが存在しません。": Exit Sub
    If Right(取込ファイル名, 5) <> ".xlsx" Then MsgBox "指定ファイルがxlsxファイルではありません。": Exit Sub
    
    ' 対象ブックを開く
    Dim path保存フォルダ As String: path保存フォルダ = FSO.GetParentFolderName(path取込ファイル)
    Dim wb取込ファイル As Workbook
    Set wb取込ファイル = ブックを開いていなければ開く(path保存フォルダ, 取込ファイル名)
    
    ' シートの存在チェック
    If Isシートが存在する("注文書", wb取込ファイル) = False Then MsgBox "注文書シートがないファイルです。": Exit Sub
    Dim ws注文書 As Worksheet: Set ws注文書 = wb取込ファイル.Worksheets("注文書")
    
    ' シートのレイアウトチェック
    If Is注文書シート(ws注文書) = False Then MsgBox "注文書シートのレイアウトが異なります。": Exit Sub

    ' 対象年度が異なれば取込を停止
    If WS販売データ.Range(Adrs販売データ_年度) <> Get年度(ws注文書.Range(Adrs注文書_注文日)) Then MsgBox "注文書の年度が異なります。": Exit Sub
        
    ' 取込済判定
    If Is指定注文書が販売データに取込済(ws注文書) Then MsgBox "同日同購入者のデータが既に存在します。": Exit Sub

    Dim R_第1出力行 As Long: R_第1出力行 = Get最終行(WS販売データ) + 1
        
    ' ■ 取込メインプロシージャを実行
    Call 指定の注文書シートを販売データに取り込む(ws注文書)
    
    Dim R_最終出力行 As Long: R_最終出力行 = Get最終行(WS販売データ)
            
    WS販売データ.Activate
    WS販売データ.Range(WS販売データ.Rows(R_第1出力行) _
                     , WS販売データ.Rows(R_最終出力行)).Select
    MsgBox "データの取込を完了しました。"
    
End Sub

標準モジュール:Pr2_注文書取込_フォルダ一括

Option Explicit

' マクロ② 指定フォルダ内の全注文書を取込
Sub 指定フォルダ内にあるすべての注文書ファイルを販売データに取り込む()

    ' 取込ログをクリア
    WS実行シート.Range(WS実行シート.Rows(R1st取込ログ), WS実行シート.Rows(Get最終行(WS実行シート))).Value = ""

    ' 取込フォルダの存在チェック
    Dim Path取込フォルダ As String: Path取込フォルダ = WS実行シート.Range(Adrs実行シート_フォルダパス)
    If FSO.FolderExists(Path取込フォルダ) = False Then MsgBox "指定したフォルダが存在しません。": Exit Sub
    
    ' 処理後の移動先フォルダを作成
    Dim Path完了フォルダ As String: Path完了フォルダ = Path取込フォルダ & "\" & Format(Date, "yyyymmdd") & "取込済"
    Dim Path除外フォルダ As String: Path除外フォルダ = Path取込フォルダ & "\除外ファイル"
    If FSO.FolderExists(Path完了フォルダ) = False Then FSO.CreateFolder Path完了フォルダ
    If FSO.FolderExists(Path除外フォルダ) = False Then FSO.CreateFolder Path除外フォルダ
    
    ' 第1出力列を記憶
    Dim R_第1出力行 As Long: R_第1出力行 = Get最終行(WS販売データ) + 1
    
    ' フォルダ内のすべてのxlsxファイルを取得
    Dim 取込ファイルNo As Long: 取込ファイルNo = 1
    Dim R_ログ As Long: R_ログ = R1st取込ログ
    Dim 取込ファイル As File
    For Each 取込ファイル In FSO.GetFolder(Path取込フォルダ).Files
    
        ' ファイル名とNoをログに記録
        WS実行シート.Cells(R_ログ, CNo取込ログ.No) = 取込ファイルNo
        WS実行シート.Cells(R_ログ, CNo取込ログ.取込ファイル名) = 取込ファイル.Name
        
        ' ファイルがxlsxでない
        If FSO.GetExtensionName(取込ファイル.Path) <> "xlsx" Then
            WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "xlsxでないファイル"
        Else
        
            ' 注文書シートの取得
            On Error Resume Next
                Dim wb取込ファイル As Workbook
                Set wb取込ファイル = ブックを開いていなければ開く(Path取込フォルダ, 取込ファイル.Name)
                Dim ws注文書 As Worksheet: Set ws注文書 = wb取込ファイル.Worksheets("注文書")
            On Error GoTo 0
            
            ' 注文書シートがない
            If ws注文書 Is Nothing Then
                WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "注文書シートなし"
            
            ' 注文書のレイアウトが不一致
            ElseIf Is注文書シート(ws注文書) = False Then
                WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "シートレイアウト不一致"
            
            ' 対象年度でない
            ElseIf WS販売データ.Range(Adrs販売データ_年度) <> Get年度(ws注文書.Range(Adrs注文書_注文日)) Then
                WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "データ年度不一致"
                
            ' 取込済
            ElseIf Is指定注文書が販売データに取込済(ws注文書) Then
                WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "取込済の注文書"
            
            ' ■ 取込を実行
            Else
                Call 指定の注文書シートを販売データに取り込む(ws注文書)
                WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "完了"
            End If
            
            ' ファイルを開いていたら閉じる
            If Not wb取込ファイル Is Nothing Then wb取込ファイル.Close False
            
        End If
    
        ' 結果が「完了」かどうかで判定
        If WS実行シート.Cells(R_ログ, CNo取込ログ.結果) = "完了" Then
            取込ファイル.Move Path完了フォルダ & "\"
        Else
            取込ファイル.Move Path除外フォルダ & "\"
        End If
    
        ' 次のファイルへ
        取込ファイルNo = 取込ファイルNo + 1
        R_ログ = R_ログ + 1
    Next ' フォルダ内のすべてのファイルを走査
    
    Dim R_最終出力行 As Long: R_最終出力行 = Get最終行(WS販売データ)
    
    If R_第1出力行 = R_最終出力行 Then
        MsgBox "取込可能なファイルがひとつもありませんでした。"
    Else
        WS販売データ.Activate
        WS販売データ.Range(WS販売データ.Rows(R_第1出力行) _
                         , WS販売データ.Rows(R_最終出力行)).Select
        MsgBox "データの取込を完了しました。"
    End If

End Sub

' フォルダのダイアログ選択
Sub フォルダを選択する()
    
    WS実行シート.Range(Adrs実行シート_フォルダパス) = GetPathダイアログボックスでフォルダを選択する(ThisWorkbook.Path)

End Sub

Function GetPathダイアログボックスでフォルダを選択する(Optional Path初期表示フォルダ As String = "") As String
    With Application.FileDialog(msoFileDialogFolderPicker)

        If Path初期表示フォルダ <> "" Then .InitialFileName = Path初期表示フォルダ

        If .Show Then: GetPathダイアログボックスでフォルダを選択する = .SelectedItems(1)
    
    End With
End Function

標準モジュール:Ut_汎用関数

Option Explicit

' FileSystemObjectのオブジェクト
Public FSO As New FileSystemObject

' 最終行の取得
Function Get最終行(指定シート As Worksheet, Optional 列番号 As Long = -1) As Long
    With 指定シート
    
        ' 列番号を省略時はシートの最終行
        If 列番号 = -1 Then
            Get最終行 = .UsedRange.Rows.Count + .UsedRange.Row - 1
    
        ' 列番号を指定時は列の最終行
        Else
            Get最終行 = .Cells(.Rows.Count, 列番号).End(xlUp).Row
        End If
    
    End With
End Function

' ブックを開いていなければ開く
Function ブックを開いていなければ開く(フォルダパス As String, ブック名 As String) As Workbook

    If Isブックを開いている(ブック名) Then
        Set ブックを開いていなければ開く = Workbooks(ブック名)
    Else
        On Error Resume Next
        Set ブックを開いていなければ開く = Workbooks.Open(フォルダパス & "\" & ブック名)
        On Error GoTo 0
    End If
    
End Function

' ブックのOpenチェック
Function Isブックを開いている(判定ブック名 As String) As Boolean

    ' 開いているすべてのブックを走査
    Dim wb As Workbook
    For Each wb In Workbooks
    
        ' ブック名が一致したらTrueを返してExit
        If wb.Name = 判定ブック名 Then
            Isブックを開いている = True
            Exit Function
        End If
        
    Next
    
End Function

' シートの存在チェック
Function Isシートが存在する(判定シート名 As String, 指定ブック As Workbook) As Boolean

    ' ブック内の全シートを走査
    Dim ws As Worksheet
    For Each ws In 指定ブック.Worksheets

        ' シート名が一致したらTrueを返してExit
        If ws.Name = 判定シート名 Then
            Isシートが存在する = True
            Exit Function
        End If

    Next

End Function

' 年度の取得
Function Get年度(ByVal 日付 As Date) As Long
    If Month(日付) >= 4 Then
        Get年度 = Year(日付)
    Else
        Get年度 = Year(日付) - 1
    End If
End Function

コードの解説

今回の課題は本ブログの基本問題集#2でも出題しており、
解答コードと解説ページも以下に公開しています。
VBA問題#2「注文書をデータ取込」マクロ①解答
VBA問題#2「注文書をデータ取込」マクロ②解答
VBA問題#2「注文書をデータ取込」完成版解答(挑戦ポイント制覇)

各コードの細かい解説は上記の記事をご参考ください。

今回の課題はシンプルでしたので、
「問題集の解答として用意した上記リンクにあるコード」と、
「実際に自分が作る想定で書いた本記事コード」で、
ロジック上は違いはありませんでした。

ただしコードの中身としては、
こちらはすべてFileSystemObjectを使用したコードになっています。

以下の完成版解答のコードと比べていただき、Dirシリーズで書いた場合と、
FileSystemObjectを使って書いた場合のコードの違いを参考にしてみて下さい。

www.limecode.jp

それ以外のロジックの解説や挑戦ポイントへの対応方法も、
上記の完成版解答で詳しく解説しています。

よろしければご参考ください。