야요이 판매 데이터 추출

템플릿

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 strTemplatePath As String  'テンプレートのパス
Public strTyusyutuPath As String  '抽出結果出力用のパス


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

Sub Auto_Open()

    GetWhoAmI
    UserForm_DataAnalysis.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"
    strTemplatePath = strMyBookPath & "\Template"
    strTyusyutuPath = strMyBookPath & "\抽出結果"

End Sub

양식

Option Explicit

Const C_Master_Items = "商品台帳"
Const C_Master_Customers = "得意先台帳"
Const C_DataAllFileName = "売上明細_ALL.csv"
Const C_TemplateExcelFileName_1 = "テンプレート_1.xlsm"
Const C_Sheet_TyusyutuJyoken = "抽出条件"
Const C_Sheet_TyusyutuKekka = "抽出結果"

Dim strDataAll As String
Dim strTemplateFile As String
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 Uriagebi(1 To C_SheetRowMax) As String
Dim DenpyoBango(1 To C_SheetRowMax) As String
Dim TokuisakiCode(1 To C_SheetRowMax) As String
Dim TokuisakiName(1 To C_SheetRowMax) As String
Dim TantosyaCode(1 To C_SheetRowMax) As String
Dim TantosyaName(1 To C_SheetRowMax) As String
Dim SyohinCode(1 To C_SheetRowMax) As String
Dim SyohinName(1 To C_SheetRowMax) As String
Dim Suryo(1 To C_SheetRowMax) As String
Dim Tanka(1 To C_SheetRowMax) As String
Dim Kingaku(1 To C_SheetRowMax) As String

Private Sub CommandButton_Tyusyutu_Click()
    Dim Joken_YearStart As String
    Dim Joken_MonthStart As String
    Dim Joken_DayStart As String
    Dim Joken_YearEnd As String
    Dim Joken_MonthEnd As String
    Dim Joken_DayEnd As String
    Dim Joken_Item(1 To 5) As String
    Dim Joken_Customer(1 To 5) As String
    Dim bJoken_Kikan_Ari As Boolean
    Dim strJokenStart As String
    Dim strJokenEnd As String
    Dim bJoken_Item_Ari As Boolean
    Dim bJoken_Customer_Ari As Boolean
    Dim bTarget As Boolean
    Dim strOutputFile As String
    Dim i As Integer

    Joken_YearStart = ComboBox_YearStart.Text
    Joken_MonthStart = ComboBox_MonthStart.Text
    Joken_DayStart = ComboBox_DayStart.Text
    Joken_YearEnd = ComboBox_YearEnd.Text
    Joken_MonthEnd = ComboBox_MonthEnd.Text
    Joken_DayEnd = ComboBox_DayEnd.Text
    Joken_Item(1) = ComboBox_Item_1.Text
    Joken_Item(2) = ComboBox_Item_2.Text
    Joken_Item(3) = ComboBox_Item_3.Text
    Joken_Item(4) = ComboBox_Item_4.Text
    Joken_Item(5) = ComboBox_Item_5.Text
    Joken_Customer(1) = ComboBox_Customer_1.Text
    Joken_Customer(2) = ComboBox_Customer_2.Text
    Joken_Customer(3) = ComboBox_Customer_3.Text
    Joken_Customer(4) = ComboBox_Customer_4.Text
    Joken_Customer(5) = ComboBox_Customer_5.Text

    bJoken_Kikan_Ari = False
    If Joken_YearStart = "----" And Joken_MonthStart = "--" And Joken_DayStart = "--" _
      And Joken_YearEnd = "----" And Joken_MonthEnd = "--" And Joken_DayEnd = "--" Then
    ElseIf Joken_YearStart = "----" Or Joken_YearEnd = "----" Then
        MsgBox "期間指定(年)に誤りがあります。"
        Exit Sub
    ElseIf Joken_MonthStart = "--" Or Joken_MonthEnd = "--" Then
        MsgBox "期間指定(月)に誤りがあります。"
        Exit Sub
    ElseIf Joken_DayStart = "--" Or Joken_DayEnd = "--" Then
        MsgBox "期間指定(日)に誤りがあります。"
        Exit Sub
    Else
        strJokenStart = Joken_YearStart & "/" & Joken_MonthStart & "/" & Joken_DayStart
        strJokenEnd = Joken_YearEnd & "/" & Joken_MonthEnd & "/" & Joken_DayEnd
        If Not IsDate(strJokenStart) Then
            MsgBox "期間指定(開始年月日)が日付データではありません。"
            Exit Sub
        ElseIf Not IsDate(strJokenEnd) Then
            MsgBox "期間指定(終了年月日)が日付データではありません。"
            Exit Sub
        ElseIf strJokenStart > strJokenEnd Then
            MsgBox "期間指定に誤りがあります。(開始年月日≦終了年月日)として下さい。"
            Exit Sub
        Else
            bJoken_Kikan_Ari = True
        End If
    End If

    'テンプレートエクセルから出力用エクセルを作成する
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    strOutputFile = strTyusyutuPath & "\" & "抽出結果_" & Format(Now, "YYYYMMDD_HHMMSS") & ".xlsm"
    fso.CopyFile strTemplateFile, strOutputFile

    Dim targetBook As Workbook
    Set targetBook = Workbooks.Open(strOutputFile)
    Dim tSheet As Worksheet
    Set tSheet = targetBook.Worksheets(C_Sheet_TyusyutuJyoken)
    tSheet.Cells(1, 1) = "期間"
    tSheet.Cells(1, 2) = Joken_YearStart & "年" & Joken_MonthStart & "月" & Joken_DayStart & "日～" & _
      Joken_YearEnd & "年" & Joken_MonthEnd & "月" & Joken_DayEnd & "日"
    tSheet.Cells(2, 1) = "商品"
    tSheet.Cells(2, 2) = Joken_Item(1)
    tSheet.Cells(3, 2) = Joken_Item(2)
    tSheet.Cells(4, 2) = Joken_Item(3)
    tSheet.Cells(5, 2) = Joken_Item(4)
    tSheet.Cells(6, 2) = Joken_Item(5)
    tSheet.Cells(7, 1) = "得意先"
    tSheet.Cells(7, 2) = Joken_Customer(1)
    tSheet.Cells(8, 2) = Joken_Customer(2)
    tSheet.Cells(9, 2) = Joken_Customer(3)
    tSheet.Cells(10, 2) = Joken_Customer(4)
    tSheet.Cells(11, 2) = Joken_Customer(5)
    Set tSheet = targetBook.Worksheets(C_Sheet_TyusyutuKekka)

    bJoken_Item_Ari = False
    For i = 1 To 5
        If Mid(Joken_Item(i), 1, 1) <> "-" Then
            bJoken_Item_Ari = True
            Joken_Item(i) = Trim(Mid(Joken_Item(i), 1, 10))
        Else
            Joken_Item(i) = ""
        End If
    Next
    bJoken_Customer_Ari = False
    For i = 1 To 5
        If Mid(Joken_Customer(i), 1, 1) <> "-" Then
            bJoken_Customer_Ari = True
            Joken_Customer(i) = Trim(Mid(Joken_Customer(i), 1, 10))
        Else
            Joken_Customer(i) = ""
        End If
    Next

    Dim strLine As String
    Dim v As Variant
    Dim lngLineNumber As Long
    Dim idx As Long
    Dim num As Integer

    num = FreeFile
    Open strDataAll For Input As #num
    lngLineNumber = 0
    idx = 0
    Do Until EOF(num)
        Line Input #num, strLine
        lngLineNumber = lngLineNumber + 1
        If lngLineNumber <> 1 Then
            strLine = Mid(strLine, 2, Len(strLine) - 1) '行頭の"を削除する
            strLine = Mid(strLine, 1, Len(strLine) - 1) '行末の"を削除する
            v = Split(strLine, """,""") '","で区切る
            strUriagebi = v(0)
            strDenpyoBango = v(1)
            strTokuisakiCode = v(2)
            strTokuisakiName = v(3)
            strTantosyaCode = v(4)
            strTantosyaName = v(5)
            strSyohinCode = v(6)
            strSyohinName = v(7)
            strSuryo = v(8)
            strTanka = v(9)
            strKingaku = v(10)
            bTarget = True
            If bJoken_Kikan_Ari Then
                If strUriagebi < strJokenStart Then
                    bTarget = False
                ElseIf strUriagebi > strJokenEnd Then
                    bTarget = False
                End If
            End If
            If bTarget Then
                If bJoken_Item_Ari Then
                    bTarget = False
                    i = 1
                    Do While (bTarget = False) And Not (i > 5)
                        If strSyohinCode = Joken_Item(i) Then
                            bTarget = True
                        End If
                        i = i + 1
                    Loop
                End If
            End If
            If bTarget Then
                If bJoken_Customer_Ari Then
                    bTarget = False
                    i = 1
                    Do While (bTarget = False) And Not (i > 5)
                        If strTokuisakiCode = Joken_Customer(i) Then
                            bTarget = True
                        End If
                        i = i + 1
                    Loop
                End If
            End If

            If bTarget Then
                idx = idx + 1
                Uriagebi(idx) = strUriagebi
                DenpyoBango(idx) = strDenpyoBango
                TokuisakiCode(idx) = strTokuisakiCode
                TokuisakiName(idx) = strTokuisakiName
                TantosyaCode(idx) = strTantosyaCode
                TantosyaName(idx) = strTantosyaName
                SyohinCode(idx) = strSyohinCode
                SyohinName(idx) = strSyohinName
                Suryo(idx) = strSuryo
                Tanka(idx) = strTanka
                Kingaku(idx) = strKingaku
                'シートに書き出す
                tSheet.Cells(idx + 1, 1) = Uriagebi(idx)
                tSheet.Cells(idx + 1, 2) = DenpyoBango(idx)
                tSheet.Cells(idx + 1, 3) = TokuisakiCode(idx)
                tSheet.Cells(idx + 1, 4) = TokuisakiName(idx)
                tSheet.Cells(idx + 1, 5) = TantosyaCode(idx)
                tSheet.Cells(idx + 1, 6) = TantosyaName(idx)
                tSheet.Cells(idx + 1, 7) = SyohinCode(idx)
                tSheet.Cells(idx + 1, 8) = SyohinName(idx)
                tSheet.Cells(idx + 1, 9) = Suryo(idx)
                tSheet.Cells(idx + 1, 10) = Tanka(idx)
                tSheet.Cells(idx + 1, 11) = Kingaku(idx)
            End If
        End If
    Loop
    Close #num

    targetBook.Save
    targetBook.Close
    Label_Msg.Caption = "抽出結果を保存しました。" & strOutputFile


End Sub


Private Sub Frame1_Click()

End Sub

Private Sub UserForm_Initialize()
    Me.Caption = strSystemName
    Dim yyyy As String
    Dim mm As String
    Dim dd As String
    Dim strMasterItems As String
    Dim strMasterCustomers As String
    Dim strLine As String
    Dim i As Integer
    Dim lngLineNumber As Long
    Dim num As Integer
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'データとマスタの存在チェック
    strMasterItems = strCsvMasterPath & "\" & C_Master_Items & ".csv"
    If Not fso.FileExists(strMasterItems) Then
        MsgBox strMasterItems & "が存在しません。"
        Exit Sub
    End If
    strMasterCustomers = strCsvMasterPath & "\" & C_Master_Customers & ".csv"
    If Not fso.FileExists(strMasterCustomers) Then
        MsgBox strMasterCustomers & "が存在しません。"
        Exit Sub
    End If
    strDataAll = strCsvDataAllPath & "\" & C_DataAllFileName
    If Not fso.FileExists(strDataAll) Then
        MsgBox strDataAll & "が存在しません。"
        Exit Sub
    End If
    strTemplateFile = strTemplatePath & "\" & C_TemplateExcelFileName_1
    If Not fso.FileExists(strDataAll) Then
        MsgBox C_TemplateExcelFileName_1 & "が存在しません。"
        Exit Sub
    End If

    ComboBox_YearStart.Clear
    ComboBox_YearStart.AddItem ("----")
    For i = Year(Date) To 2009 Step -1
        yyyy = CStr(i)
        ComboBox_YearStart.AddItem (yyyy)
    Next
    ComboBox_YearStart.ListIndex = 0

    ComboBox_MonthStart.Clear
    ComboBox_MonthStart.AddItem ("--")
    For i = 1 To 12
        mm = CStr(i)
        If Len(mm) = 1 Then
            mm = "0" & mm
        End If
        ComboBox_MonthStart.AddItem (mm)
    Next
    ComboBox_MonthStart.ListIndex = 0

    ComboBox_DayStart.Clear
    ComboBox_DayStart.AddItem ("--")
    For i = 1 To 31
        dd = CStr(i)
        If Len(dd) = 1 Then
            dd = "0" & dd
        End If
        ComboBox_DayStart.AddItem (dd)
    Next
    ComboBox_DayStart.ListIndex = 0


    ComboBox_YearEnd.Clear
    ComboBox_YearEnd.AddItem ("----")
    For i = Year(Date) To 2009 Step -1
        yyyy = CStr(i)
        ComboBox_YearEnd.AddItem (yyyy)
    Next
    ComboBox_YearEnd.ListIndex = 0

    ComboBox_MonthEnd.Clear
    ComboBox_MonthEnd.AddItem ("--")
    For i = 1 To 12
        mm = CStr(i)
        If Len(mm) = 1 Then
            mm = "0" & mm
        End If
        ComboBox_MonthEnd.AddItem (mm)
    Next
    ComboBox_MonthEnd.ListIndex = 0

    ComboBox_DayEnd.Clear
    ComboBox_DayEnd.AddItem ("--")
    For i = 1 To 31
        dd = CStr(i)
        If Len(dd) = 1 Then
            dd = "0" & dd
        End If
        ComboBox_DayEnd.AddItem (dd)
    Next
    ComboBox_DayEnd.ListIndex = 0

    Dim v As Variant
    Dim strCode As String
    Dim strName As String

    Dim objComboBoxItem As ComboBox
    For i = 1 To 5
        If i = 1 Then
            Set objComboBoxItem = ComboBox_Item_1
        ElseIf i = 2 Then
            Set objComboBoxItem = ComboBox_Item_2
        ElseIf i = 3 Then
            Set objComboBoxItem = ComboBox_Item_3
        ElseIf i = 4 Then
            Set objComboBoxItem = ComboBox_Item_4
        ElseIf i = 5 Then
            Set objComboBoxItem = ComboBox_Item_5
        End If
        objComboBoxItem.Clear
        objComboBoxItem.AddItem ("----------:")
        objComboBoxItem.ListIndex = 0
    Next
    num = FreeFile
    Open strMasterItems For Input As #num
    lngLineNumber = 0
    Do Until EOF(num)
        Line Input #num, strLine
        lngLineNumber = lngLineNumber + 1
        If lngLineNumber <> 1 Then
            strLine = Mid(strLine, 2, Len(strLine) - 1) '行頭の"を削除する
            strLine = Mid(strLine, 1, Len(strLine) - 1) '行末の"を削除する
            v = Split(strLine, """,""") '","で区切る
            strCode = Mid(v(0) & String(10, " "), 1, 10)    '右にスペースを供給
            strName = v(1)
            For i = 1 To 5
                If i = 1 Then
                    Set objComboBoxItem = ComboBox_Item_1
                ElseIf i = 2 Then
                    Set objComboBoxItem = ComboBox_Item_2
                ElseIf i = 3 Then
                    Set objComboBoxItem = ComboBox_Item_3
                ElseIf i = 4 Then
                    Set objComboBoxItem = ComboBox_Item_4
                ElseIf i = 5 Then
                    Set objComboBoxItem = ComboBox_Item_5
                End If
                objComboBoxItem.AddItem (strCode & ":" & strName)
            Next
        End If
    Loop
    Close #num

    Dim objComboBoxCustomer As ComboBox
    For i = 1 To 5
        If i = 1 Then
            Set objComboBoxCustomer = ComboBox_Customer_1
        ElseIf i = 2 Then
            Set objComboBoxCustomer = ComboBox_Customer_2
        ElseIf i = 3 Then
            Set objComboBoxCustomer = ComboBox_Customer_3
        ElseIf i = 4 Then
            Set objComboBoxCustomer = ComboBox_Customer_4
        ElseIf i = 5 Then
            Set objComboBoxCustomer = ComboBox_Customer_5
        End If
        objComboBoxCustomer.Clear
        objComboBoxCustomer.AddItem ("----------:")
        objComboBoxCustomer.ListIndex = 0
    Next
    num = FreeFile
    Open strMasterCustomers For Input As #num
    lngLineNumber = 0
    Do Until EOF(num)
        Line Input #num, strLine
        lngLineNumber = lngLineNumber + 1
        If lngLineNumber <> 1 Then
            strLine = Mid(strLine, 2, Len(strLine) - 1) '行頭の"を削除する
            strLine = Mid(strLine, 1, Len(strLine) - 1) '行末の"を削除する
            v = Split(strLine, """,""") '","で区切る
            strCode = Mid(v(0) & String(10, " "), 1, 10)    '右にスペースを供給
            strName = v(1)
            For i = 1 To 5
                If i = 1 Then
                    Set objComboBoxCustomer = ComboBox_Customer_1
                ElseIf i = 2 Then
                    Set objComboBoxCustomer = ComboBox_Customer_2
                ElseIf i = 3 Then
                    Set objComboBoxCustomer = ComboBox_Customer_3
                ElseIf i = 4 Then
                    Set objComboBoxCustomer = ComboBox_Customer_4
                ElseIf i = 5 Then
                    Set objComboBoxCustomer = ComboBox_Customer_5
                End If
                objComboBoxCustomer.AddItem (strCode & ":" & strName)
            Next
        End If
    Loop
    Close #num

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