[VBA]カラーミーの受注データをe飛伝Ⅲ用に書き換える

Option Explicit

Private Const TARGET_HEADER As String = "配達指定時間帯"

Public Type ConvertResult
    TotalCount As Long
    ConvertCount As Long
    UnknownCount As Long
    OutputPath As String
End Type

Public Sub 変換開始()

    Dim csvFile As Variant
    Dim result As ConvertResult

    On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Cursor = xlWait

    csvFile = Application.GetOpenFilename( _
        FileFilter:="CSVファイル (*.csv),*.csv", _
        Title:="カラーミーショップのCSVを選択してください")

    If csvFile = False Then GoTo ExitProc

    result = ConvertCSV(CStr(csvFile))

    MsgBox _
        "変換が完了しました。" & vbCrLf & vbCrLf & _
        "読込件数　：" & Format(result.TotalCount, "#,##0") & " 件" & vbCrLf & _
        "変換件数　：" & Format(result.ConvertCount, "#,##0") & " 件" & vbCrLf & _
        "未変換件数：" & Format(result.UnknownCount, "#,##0") & " 件" & vbCrLf & vbCrLf & _
        "保存先：" & vbCrLf & result.OutputPath, _
        vbInformation, _
        "e飛伝Ⅲ CSV変換"

    OpenFolder result.OutputPath

ExitProc:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    Exit Sub

ErrHandler:
    MsgBox _
        "エラーが発生しました。" & vbCrLf & vbCrLf & _
        Err.Description, _
        vbCritical, _
        "e飛伝Ⅲ CSV変換"
    Resume ExitProc

End Sub

Private Function ConvertCSV(ByVal inputPath As String) As ConvertResult

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim result As ConvertResult
    Dim timeCol As Long
    Dim lastRow As Long
    Dim r As Long
    Dim beforeValue As String
    Dim afterValue As String
    Dim outputPath As String

    If LCase$(Right$(inputPath, 4)) <> ".csv" Then
        Err.Raise vbObjectError + 100, , "CSVファイルを選択してください。"
    End If

    Workbooks.OpenText _
        Filename:=inputPath, _
        Origin:=932, _
        DataType:=xlDelimited, _
        Comma:=True, _
        Local:=True

    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets(1)

    timeCol = FindHeaderColumn(ws, TARGET_HEADER)

    If timeCol = 0 Then
        wb.Close SaveChanges:=False
        Err.Raise vbObjectError + 101, , _
            "「" & TARGET_HEADER & "」列が見つかりません。" & vbCrLf & _
            "カラーミーショップのCSVか確認してください。"
    End If

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    If lastRow < 2 Then
        result.TotalCount = 0
    Else
        result.TotalCount = lastRow - 1
    End If

    For r = 2 To lastRow

        beforeValue = Trim$(CStr(ws.Cells(r, timeCol).Value))

        If Len(beforeValue) > 0 Then

            afterValue = ConvertTimeValue(beforeValue)

            If afterValue <> "" Then
                If beforeValue <> afterValue Then
                    ws.Cells(r, timeCol).NumberFormat = "@"
                    ws.Cells(r, timeCol).Value = afterValue
                    result.ConvertCount = result.ConvertCount + 1
                End If
            Else
                result.UnknownCount = result.UnknownCount + 1
            End If

        End If

    Next r

    outputPath = BuildOutputPath(inputPath)

    wb.SaveAs _
        Filename:=outputPath, _
        FileFormat:=xlCSV, _
        Local:=True

    wb.Close SaveChanges:=False

    result.OutputPath = outputPath
    ConvertCSV = result

End Function

Private Function FindHeaderColumn(ByVal ws As Worksheet, ByVal headerName As String) As Long

    Dim lastCol As Long
    Dim c As Long
    Dim value As String

    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    For c = 1 To lastCol
        value = Trim$(CStr(ws.Cells(1, c).Value))
        If value = headerName Then
            FindHeaderColumn = c
            Exit Function
        End If
    Next c

    FindHeaderColumn = 0

End Function

Private Function ConvertTimeValue(ByVal value As String) As String

    value = Trim$(value)

    Select Case value

        Case "午前中"
            ConvertTimeValue = "01"

        Case "12:00 ～ 14:00"
            ConvertTimeValue = "12"

        Case "14:00 ～ 16:00"
            ConvertTimeValue = "14"

        Case "16:00 ～ 18:00"
            ConvertTimeValue = "16"

        Case "18:00 ～ 20:00"
            ConvertTimeValue = "18"

        Case "19:00 ～ 21:00"
            ConvertTimeValue = "19"

        Case "01", "12", "14", "16", "18", "19"
            ConvertTimeValue = value

        Case Else
            ConvertTimeValue = ""

    End Select

End Function

Private Function BuildOutputPath(ByVal inputPath As String) As String

    Dim folderPath As String
    Dim fileName As String
    Dim baseName As String
    Dim extension As String
    Dim pos As Long
    Dim timestamp As String

    folderPath = Left$(inputPath, InStrRev(inputPath, "\"))
    fileName = Mid$(inputPath, InStrRev(inputPath, "\") + 1)

    pos = InStrRev(fileName, ".")

    If pos > 0 Then
        baseName = Left$(fileName, pos - 1)
        extension = Mid$(fileName, pos)
    Else
        baseName = fileName
        extension = ".csv"
    End If

    timestamp = Format(Now, "yyyymmdd_HHMMSS")

    BuildOutputPath = folderPath & baseName & "_" & timestamp & extension

End Function

Private Sub OpenFolder(ByVal filePath As String)

    Dim folderPath As String

    If Len(filePath) = 0 Then Exit Sub

    folderPath = Left$(filePath, InStrRev(filePath, "\") - 1)

    Shell "explorer.exe """ & folderPath & """", vbNormalFocus

End Sub