야요이 판매 판매 항목의 Excel 데이터를 CSV로 변환

Module1

Option Explicit

Public Const C_SheetRowMax = 1048576
Public Const C_Sheet_Log = "Log"

Public strSystemName As String
Public strMyBookPath As String  '自分自身のパス
Public strMyBookName As String  '自分自身のブック名
Public strExcelDataPath As String  'エクセルデータのパス
Public strExcelMasterPath As String  'エクセルマスタ（台帳）のパス
Public strCsvDataPath As String  'CSVデータのパス
Public strCsvDataAllPath As String  'CSVマージデータのパス
Public strCsvMasterPath As String  'CSVマスタのパス


Public strOutputBookName As String  '出力先ブック名
Public OutputBook As Workbook
Public strSheetName As String

Sub Auto_Open()

    GetWhoAmI
    UserForm_Excel2Csv.Show vbModeless


End Sub

Sub GetWhoAmI()
    Dim strFileNameSplit() As String

    strMyBookPath = ActiveWorkbook.Path
    strMyBookName = ActiveWorkbook.Name
    strFileNameSplit = Split(strMyBookName, ".")
    strSystemName = strFileNameSplit(0)
    strExcelDataPath = strMyBookPath & "\ExcelData"
    strExcelMasterPath = strMyBookPath & "\ExcelMaster"
    strCsvDataPath = strMyBookPath & "\CsvData"
    strCsvDataAllPath = strMyBookPath & "\CsvData_ALL"
    strCsvMasterPath = strMyBookPath & "\CsvMaster"

End Sub

양식

Option Explicit

Const C_Master_Items = "商品台帳"
Const C_Master_Customers = "得意先台帳"
Const C_DataAllFileName = "売上明細_ALL.csv"

Private Sub CommandButton_Data2Csv_Click()
    Dim strExcelData As String
    Dim strCsvData As String
    Dim strText As String

    strText = ComboBox_ExcelData.Text
    If strText = "" Then
        MsgBox "データを選択して下さい。"
        Exit Sub
    End If

    '文字列"yyyy年mm月"から yyyy, mm を取得する  ex)2019年1月→yyyy="2019", mm="01"
    Dim yyyy As String
    Dim mm As String
    yyyy = Mid(strText, 1, InStr(strText, "年") - 1)
    mm = Mid(strText, InStr(strText, "年") + 1, 2)
    If Mid(mm, 2, 1) = "月" Then
        mm = "0" & Mid(mm, 1, 1)
    End If
    If Not (Len(yyyy) = 4 And Len(mm) = 2) Then
        MsgBox "データ[" & strText & "]に誤りがあります。"
        Exit Sub
    End If

    Dim strMainFileName As String
    strMainFileName = "売上明細_" & yyyy & mm
    strExcelData = strExcelDataPath & "\" & strMainFileName & ".xlsx"
    strCsvData = strCsvDataPath & "\" & strMainFileName & ".csv"

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '入力ファイル（エクセルデータ）の存在チェック
    If Not fso.FileExists(strExcelData) Then
        MsgBox "選択したマスタ" & vbCrLf & strExcelData & vbCrLf & "が存在しません。"
        Exit Sub
    End If
    '出力フォルダの存在チェック
    Dim temp As String
    If Not fso.FolderExists(strCsvDataPath) Then
        temp = fso.CreateFolder(strCsvDataPath)
    End If
    '出力ファイル(CSV)の存在チェック
    If fso.FileExists(strCsvData) Then
        If MsgBox("選択したデータは" & vbCrLf & fso.GetFile(strCsvData).DateLastModified & vbCrLf & "にCSV変換されています。" & vbCrLf & "更新しますか？", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If

    'エクセルを配列にセットする
    Dim lngStartRow As Long
    Dim lngEndRow As Long
    Dim i As Long
    Dim lngRowIndex As Long
    Dim lngRowCount As Long
    Dim strUriagebi() As String
    Dim strDenpyoBango() As String
    Dim strTokuisakiCode() As String
    Dim strTokuisakiName() As String
    Dim strTantosyaCode() As String
    Dim strTantosyaName() As String
    Dim strSyohinCode() As String
    Dim strSyohinName() As String
    Dim strSuryo() As String
    Dim strTanka() As String
    Dim strKingaku() As String
    Dim bk As Workbook
    Dim sh As Worksheet
    Set bk = Workbooks.Open(Filename:=strExcelData, ReadOnly:=True)
    Set sh = bk.Worksheets("日付別")
    Dim target As Range
    Set target = sh.Range("C6").CurrentRegion
    lngStartRow = 6
    lngRowCount = target.Rows.Count
    ReDim strUriagebi(1 To lngRowCount)
    ReDim strDenpyoBango(1 To lngRowCount)
    ReDim strTokuisakiCode(1 To lngRowCount)
    ReDim strTokuisakiName(1 To lngRowCount)
    ReDim strTantosyaCode(1 To lngRowCount)
    ReDim strTantosyaName(1 To lngRowCount)
    ReDim strSyohinCode(1 To lngRowCount)
    ReDim strSyohinName(1 To lngRowCount)
    ReDim strSuryo(1 To lngRowCount)
    ReDim strTanka(1 To lngRowCount)
    ReDim strKingaku(1 To lngRowCount)

    lngRowIndex = 0
    For i = 1 To lngRowCount
        strUriagebi(i) = sh.Cells(i + lngStartRow - 1, 2)
        strDenpyoBango(i) = sh.Cells(i + lngStartRow - 1, 3)
        strTokuisakiCode(i) = sh.Cells(i + lngStartRow - 1, 6)
        strTokuisakiName(i) = sh.Cells(i + lngStartRow - 1, 7)
        strTantosyaCode(i) = sh.Cells(i + lngStartRow - 1, 11)
        strTantosyaName(i) = sh.Cells(i + lngStartRow - 1, 12)
        strSyohinCode(i) = sh.Cells(i + lngStartRow - 1, 15)
        strSyohinName(i) = sh.Cells(i + lngStartRow - 1, 16)
        strSuryo(i) = sh.Cells(i + lngStartRow - 1, 20)
        strTanka(i) = sh.Cells(i + lngStartRow - 1, 22)
        strKingaku(i) = sh.Cells(i + lngStartRow - 1, 24)
    Next
    bk.Close

    '配列からCSVに書き出す
    Dim num As Integer
    num = FreeFile
    Open strCsvData For Output As #num
    Write #num, "売上日", "伝票番号", "得意先コード", "得意先名", "担当者コード", "担当者名", "商品コード", "商品名", "数量", "単価", "金額"
    For i = 1 To lngRowCount
        If strDenpyoBango(i) <> "" Then
            Write #num, strUriagebi(i), strDenpyoBango(i), strTokuisakiCode(i), strTokuisakiName(i), strTantosyaCode(i), strTantosyaName(i), strSyohinCode(i), strSyohinName(i), strSuryo(i), strTanka(i), strKingaku(i)
        End If
    Next
    Close #num

    Label_Msg.Caption = strMainFileName & ".csv を出力しました。"

End Sub

Private Sub CommandButton_DataMerge_Click()
    Dim strCsvDataAll As String
    strCsvDataAll = strCsvDataAllPath & "\" & C_DataAllFileName

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '出力フォルダの存在チェック
    Dim temp As String
    If Not fso.FolderExists(strCsvDataAllPath) Then
        temp = fso.CreateFolder(strCsvDataAllPath)
    End If
    '出力ファイルの存在チェック
    If fso.FileExists(strCsvDataAll) Then
        If MsgBox("ファイルは" & vbCrLf & fso.GetFile(strCsvDataAll).DateLastModified & vbCrLf & "に出力されています。" & vbCrLf & "更新しますか？", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If

    'CSVファイルを参照してファイル名の古いものからAddしてゆく
    Dim num As Integer
    Dim num_in  As Integer
    num = FreeFile
    Open strCsvDataAll For Output As #num
    Write #num, "売上日", "伝票番号", "得意先コード", "得意先名", "担当者コード", "担当者名", "商品コード", "商品名", "数量", "単価", "金額"

    Dim strSearch As String
    Dim strFile As String
    Dim strLine As String
    Dim lngLineNumber As Long
    strSearch = strCsvDataPath & "\売上明細_*.csv"
    strFile = Dir(strSearch)  '最初のファイル名を取得
    Do While strFile <> "" 'ファイル名が見つからなくなるまでループ
        num_in = FreeFile
        Open strCsvDataPath & "\" & strFile For Input As #num_in
        lngLineNumber = 0
        Do Until EOF(num_in)
            Line Input #num_in, strLine
            lngLineNumber = lngLineNumber + 1
            If lngLineNumber <> 1 Then
                Print #num, strLine
            End If
        Loop
        Close #num_in
        strFile = Dir() '引数なしで次のファイル名を取得
    Loop
    Close #num
    Label_Msg.Caption = C_DataAllFileName & " を出力しました。"

End Sub

Private Sub CommandButton_Master2Csv_Click()
    Dim strExcelMaster As String
    Dim strCsvMaster As String
    Dim strText As String

    strText = ComboBox_ExcelMaster.Text
    If strText = "" Then
        MsgBox "マスタを選択してください。"
        Exit Sub
    End If

    Dim strMainFileName As String
    If strText = C_Master_Items Then
        strMainFileName = C_Master_Items
    ElseIf strText = C_Master_Customers Then
        strMainFileName = C_Master_Customers
    Else
        MsgBox "マスタ[" & strText & "]に誤りがあります。"
        Exit Sub
    End If
    strExcelMaster = strExcelMasterPath & "\" & strMainFileName & ".xlsx"
    strCsvMaster = strCsvMasterPath & "\" & strMainFileName & ".csv"

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '入力ファイル（エクセルマスタ）の存在チェック
    If Not fso.FileExists(strExcelMaster) Then
        MsgBox "選択したマスタ" & vbCrLf & strExcelMaster & vbCrLf & "が存在しません。"
        Exit Sub
    End If
    '出力フォルダの存在チェック
    Dim temp As String
    If Not fso.FolderExists(strCsvMasterPath) Then
        temp = fso.CreateFolder(strCsvMasterPath)
    End If
    '出力ファイル(CSV)の存在チェック
    If fso.FileExists(strCsvMaster) Then
        If MsgBox("選択したマスタは" & vbCrLf & fso.GetFile(strCsvMaster).DateLastModified & vbCrLf & "にCSV変換されています。" & vbCrLf & "更新しますか？", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If

    'エクセルを配列にセットする
    Dim lngStartRow As Long
    Dim lngEndRow As Long
    Dim i As Long
    Dim lngRowIndex As Long
    Dim lngRowCount As Long
    Dim strCode() As String
    Dim strName() As String
    Dim bk As Workbook
    Dim sh As Worksheet
    Set bk = Workbooks.Open(Filename:=strExcelMaster, ReadOnly:=True)
    Set sh = bk.Worksheets("リスト形式")
    Dim target As Range
    Set target = sh.Range("B6").CurrentRegion
    lngStartRow = 6
    lngRowCount = target.Rows.Count
    ReDim strCode(1 To lngRowCount)
    ReDim strName(1 To lngRowCount)

    lngRowIndex = 0
    For i = 1 To lngRowCount
        strCode(i) = sh.Cells(i + lngStartRow - 1, 2)
        strName(i) = sh.Cells(i + lngStartRow - 1, 3)
    Next
    bk.Close

    '配列からCSVに書き出す
    Dim num As Integer
    num = FreeFile
    Open strCsvMaster For Output As #num
    Write #num, "コード", "名称"
    For i = 1 To lngRowCount
        If strCode(i) <> "" Then
            Write #num, strCode(i), strName(i)
        End If
    Next
    Close #num

    Label_Msg.Caption = strMainFileName & ".csv を出力しました。"

End Sub

Private Sub UserForm_Initialize()
    Me.Caption = strSystemName
    ComboBox_ExcelData.Clear
    Dim yyyy As Integer
    Dim mm As Integer

    Label_ExcelData_Source.Caption = "変換元：" & strExcelDataPath
    Label_ExcelData_Target.Caption = "変換先：" & strCsvDataPath
    Label_ExcelMaster_Source.Caption = "変換元：" & strExcelMasterPath
    Label_ExcelMaster_Target.Caption = "変換先：" & strCsvMasterPath
    Label_MergeTarget.Caption = "出力先：" & strCsvDataAllPath
    Label_MergeFileName.Caption = "ファイル名：" & C_DataAllFileName

    '変換する売上明細のデータをコンボボックスに設定する
    For yyyy = Year(Date) To 2009 Step -1
        For mm = 12 To 1 Step -1
            If (yyyy = 2009) And (mm < 4) Then
                '2009年4月以前は除く
            ElseIf (yyyy = Year(Date)) And (mm > Month(Date)) Then
                '本日以降は除く
            Else
                ComboBox_ExcelData.AddItem yyyy & "年" & mm & "月"
            End If
        Next
    Next

    '変換するマスタをコンボボックスに設定する
    ComboBox_ExcelMaster.Clear
    ComboBox_ExcelMaster.AddItem C_Master_Items
    ComboBox_ExcelMaster.AddItem C_Master_Customers

    'コンボボックスを編集不可にする
    ComboBox_ExcelData.Style = fmStyleDropDownList
    ComboBox_ExcelMaster.Style = fmStyleDropDownList


End Sub

Private Sub CommandButton_End_Click()
    If ThisWorkbook.Saved = False Then
        '変更が加えられている場合
        MsgBox "シートに変更が加えられていますが、保存せずに終了します。"
        ThisWorkbook.Saved = True
    End If
    ThisWorkbook.Close
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        MsgBox "[X]ボタンでは閉じられません。", vbInformation
        Cancel = True
    End If
End Sub