メモ　データを１つのファイルにまとめる

# データ結合ツール
複数のExcelファイルのデータを１つのファイルにまとめる

## ボタン
- SelectFolderOpt
- SubFolderOpt
- DataFolderPathInput
- SelectDataFolderBtn
- ColSelectCheckBox1~x
- CutOpt_On
- CutOpt_OFF
- CutColNameLabel
- CutColNameInput
- CutValueLabel
- CutValueInput
- CutColHowToLabel
- CutOverOpt
- CutUnderOpt
- ExecuteBtn

```vb
Option Explicit
Dim gDataFolderPath As String   ' データファイル格納フォルダ
Dim gSubFolderFlag As Boolean   ' サブフォルダ選択フラグ
Dim gCutFlag As Boolean             ' カットフラグ
Dim gCutColName As String
Dim gCutValue As Double
Dim gCutOverFlag As Boolean
Dim gNewFilePath As String       ' 作成ファイルパス


' #############################
' データファイル格納フォルダ選択
' #############################
Private Sub SelectDataFolderBtn_Click()
    'FileDialogオブジェクトのインスタンス取得：フォルダ選択ダイログ
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        .ButtonName = "選択する"
        'ダイアログの初期パスを設定
        .InitialFileName = ThisWorkbook.Path
        'ダイアログを表示（キャンセル：処理抜け）
        If Not .Show Then Exit Sub
         
        '選択したフォルダのフルパスをデバッグ出力
        DataFolderPathInput.Text = .SelectedItems(1)
    End With
End Sub


' #############################
' データファイル格納フォルダ内データ収集(メイン処理)
' #############################
Private Sub ExecuteBtn_Click()
    Dim wb As Workbook
    Dim FolderPaths As Variant
    Dim colNames() As Variant
    Dim failFlag As Boolean
    
    Set wb = ThisWorkbook
    
    ' フラグ取得
    gCutFlag = CutOpt_On.Value                        ' カット設定ON/OFF取得
    gSubFolderFlag = Sheet1.SubFolderOpt.Value  ' 選択フォルダフラグ(サブフォルダ)
    
    ' 入力データチェック
    failFlag = InputChk
    
    ' 読み取り列取得
    colNames = GetCheckBoxValues(wb)
    
    If failFlag = True Or LBound(colNames) = 0 Then
        Exit Sub
    End If
    
    ' 入力項目取得
    gDataFolderPath = Sheet1.DataFolderPathInput.Text   ' データ格納フォルダパス
    If gCutFlag = True Then
        gCutOverFlag = CutOverOpt.Value
        gCutColName = CutColNameInput.Text
        gCutValue = CutValueInput.Text
    End If
    
    If gSubFolderFlag Then
        gNewFilePath = gDataFolderPath & "\Data.xlsx"
        ' サブフォルダーパス取得
        FolderPaths = GetSubFolderPaths(gDataFolderPath)
    Else
        gNewFilePath = wb.Path & "\Data.xlsx"
        ' 選択フォルダーパス取得
        ReDim FolderPaths(0)
        FolderPaths(0) = gDataFolderPath
    End If
    
    ' データファイル作成
    Call CreateDataFile(FolderPaths, colNames)
    
    MsgBox "処理が完了しました。" & vbLf & _
                "作成ファイルパス：" & gNewFilePath, vbInformation, "完了"
End Sub

' #############################
' 入力項目を確認
' #############################
Function InputChk() As Boolean
    ' フォルダが存在するかチェック
    If Dir(DataFolderPathInput.Text & "\") = "" Then
        MsgBox "指定されたフォルダが見つかりません: " & DataFolderPathInput.Text, vbExclamation
        InputChk = True
    ElseIf IsWorkbookOpen("Data.xlsx") = True Then
        MsgBox "Data.xlsxが開かれています。ファイルを閉じてください。 ", vbExclamation
        InputChk = True
'    ' データ挿入先シート名チェック
    ElseIf gCutFlag = True And CutColNameInput.Text = "" Then
        MsgBox "カット列名を入力してください。", vbExclamation
        InputChk = True
    ElseIf gCutFlag = True And CutValueInput.Text = "" Then
        MsgBox "カット値を入力してください。。", vbExclamation
        InputChk = True
    End If
End Function

' #############################
' データファイル格納フォルダ内のサブフォルダを取得
' #############################
Function GetSubFolderPaths(targetFolder As String) As Variant
    Dim subFolder As String
    Dim FolderPaths() As String
    Dim count As Integer
    
    ' フォルダのパス末尾に "\" を追加（必要なら）
    If Right(targetFolder, 1) <> "\" Then
        targetFolder = targetFolder & "\"
    End If
    
    ' 最初のフォルダを取得
    subFolder = Dir(targetFolder, vbDirectory)
    count = 0
    
    ' フォルダを順に取得
    Do While subFolder <> ""
        ' "." や ".." をスキップし、フォルダのみを取得
        If (GetAttr(targetFolder & subFolder) And vbDirectory) <> 0 Then
            If subFolder <> "." And subFolder <> ".." Then
                ' 配列のサイズを動的に変更
                ReDim Preserve FolderPaths(count)
                ' フルパスを配列に格納
                FolderPaths(count) = targetFolder & subFolder
                count = count + 1
            End If
        End If
        ' 次のフォルダを取得
        subFolder = Dir()
    Loop
    
    ' 結果を戻り値として返す
    If count = 0 Then
        GetSubFolderPaths = Array() ' 空の配列を返す
    Else
        GetSubFolderPaths = FolderPaths ' 配列を返す
    End If
End Function

' #############################
' 結合データExcelファイルを作成する処理
' #############################
Sub CreateDataFile(FolderPaths As Variant, colNames() As Variant)
    Dim newWorkbook As Workbook     ' 作成ファイルWorkBook
    Dim newWs As Worksheet              ' 作成シート
    Dim newLastCol As Long                ' 作成シートの最終行
    Dim folderParts() As String
    Dim folderName As String              ' フォルダ名(シート名に使用)
    Dim findFlag As Boolean                 ' フォルダ内のExcelファイル存在フラグ
    Dim dataFilePaths As Collection         ' 集約元データファイルパス配列
    Dim dataFilePath As Variant             ' 集約元データファイルパス
    Dim dataWb As Workbook              ' 集約元データファイルWorkbook
    Dim dataWs As Worksheet               ' 集約元データシート("GtOutput")
    Dim dataLastRow As Long
    Dim dataLastColumn As Long
    Dim sourceRng As range                 ' コピーデータ範囲
    Dim pasteStartCol As Long               ' 貼り付けデータ範囲開始列
    Dim pasteEndCol As Long                 ' 貼り付けデータ範囲終了列
    Dim pasteRng As range                   ' 貼り付けデータ範囲終了列
    Dim FolderPath As Variant               ' 集約元データファイルパス
    Dim colTitle As String                     ' 列タイトル
    Dim readCols() As Long                     ' 読み取りデータ列リスト
    Dim result As Variant
    Dim addCount As Long
    Dim cutRow As Variant
    Dim pasteEndRow As Long
    Dim pasteData As Variant
    Dim dataFileName As String
    Dim i As Long
    Dim j As Long
    
    ' 新しいブックを作成
    Set newWorkbook = Workbooks.Add
    
    For Each FolderPath In FolderPaths
        ' サブフォルダ内のExcelファイルパスリストを取得
        Set dataFilePaths = GetExcelFiles(FolderPath, findFlag)
        
        ' フォルダ内にExcelファイルが存在すれば、シートを追加し、データをコピーする
        If findFlag = True Then
            Set newWs = newWorkbook.Sheets.Add
            ' シート名を設定(サブフォルダ名)
            folderParts = Split(RTrim(FolderPath), "\")
            folderName = folderParts(UBound(folderParts))
            newWs.Name = folderName
            
            ' データをコピーする
            For Each dataFilePath In dataFilePaths
                dataFileName = Dir(dataFilePath)        ' ファイル名取得
                Set dataWb = Workbooks.Open(dataFilePath)
                Set dataWs = dataWb.Sheets(1)
                ' 元データ範囲を取得
                dataLastRow = dataWs.Cells(Rows.count, 1).End(xlUp).Row
                dataLastColumn = dataWs.Cells(1, Columns.count).End(xlToLeft).Column
                addCount = 1
                Set cutRow = Nothing
                ReDim readCols(1 To 1)
                For i = 1 To dataLastColumn
                    ' 読み取り列取得
                    colTitle = dataWs.Cells(1, i).Value
                    result = Application.Match(colTitle, colNames, 0)
                    If Not IsError(result) Then
                        ReDim Preserve readCols(1 To addCount)
                        readCols(addCount) = i
                        addCount = addCount + 1
                    End If
                    
                    ' カット行探索
                    If gCutFlag = True And colTitle = gCutColName Then
                        For j = 2 To dataLastRow
                            If gCutOverFlag = True And gCutValue <= dataWs.Cells(j, i) Then
                                cutRow = j
                                Exit For
                            ElseIf gCutOverFlag = False And gCutValue >= dataWs.Cells(j, i) Then
                                cutRow = j
                                Exit For
                            End If
                        Next j
                    End If
                Next i
                
                ' 読み取り最終行取得
                If gCutFlag = True And IsNumeric(cutRow) Then
                    pasteEndRow = cutRow - 1
                Else
                    pasteEndRow = dataLastRow
                End If
                
                ' 貼り付けデータ作成
                ReDim pasteData(1 To dataLastRow, 1 To UBound(readCols))
                For i = LBound(readCols) To UBound(readCols)
                    For j = 1 To pasteEndRow
                        pasteData(j, i) = dataWs.Cells(j, readCols(i)).Value
                    Next j
                Next i
                
'                For i = LBound(colNames) To UBound(colNames)
'                    colTitle = colNames(i)
'                    result = Application.Match(colTitle, searchRange, 0)
'                    If Not IsError(result) Then
'                        ReDim Preserve readCols(addCount)
'                        readCols(addCount) = result
'                        addCount = addCount + 1
'                    End If
'                Next i
                ' コピー先範囲を取得
                newLastCol = newWs.Cells(2, Columns.count).End(xlToLeft).Column
                If newLastCol <> 1 Then
                    pasteStartCol = newLastCol + 1
                Else
                    pasteStartCol = newLastCol
                End If
                
                ' ファイル名出力
                newWs.Cells(1, pasteStartCol).Value = dataFileName
                ' ファイルデータ出力
                newWs.Cells(2, pasteStartCol).Resize(UBound(pasteData, 1), UBound(pasteData, 2)).Value = pasteData
'                Set sourceRng = dataWs.range(dataWs.Cells(1, 1), dataWs.Cells(dataLastRow, dataLastColumn))
'                Set pasteRng = newWs.range(newWs.Cells(1, pasteStartCol), newWs.Cells(dataLastRow, pasteEndCol))
                ' データ貼り付け
'                pasteRng.Value = sourceRng.Value
                dataWb.Close False
                Set dataWb = Nothing
            Next dataFilePath
        End If
    Next FolderPath
    
    ' 指定したパスにExcelファイルを保存（既存ファイルがあれば上書き）
    Kill gNewFilePath ' 既存ファイルを削除（上書き防止）
    newWorkbook.SaveAs fileName:=gNewFilePath, FileFormat:=xlOpenXMLWorkbook ' .xlsx形式で保存
    newWorkbook.Close False ' 保存して閉じる
    
    ' メモリ解放
    Set newWorkbook = Nothing
End Sub

' #############################
' 指定フォルダ内のExcelファイル一覧取得
' #############################
Function IsWorkbookOpen(ByVal wbName As String) As Boolean
    Dim wb As Workbook
    On Error Resume Next ' エラーを無視
    Set wb = Workbooks(wbName)
    On Error GoTo 0 ' エラーハンドリングを元に戻す
    IsWorkbookOpen = Not wb Is Nothing
End Function

' #############################
' 指定フォルダ内のExcelファイル一覧取得
' #############################
Function GetExcelFiles(ByVal FolderPath As Variant, findFlag As Boolean) As Collection
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim fileList As Collection
    Dim i As Integer
    
    ' フォルダパスを指定
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    ' FileSystemObject を作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(FolderPath)
    
    ' コレクションを作成
    Set fileList = New Collection
    
    ' フォルダ内のすべてのファイルをループ
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) Like "xlsx*" And Not Left(file.Name, 2) = "~$" Then
            fileList.Add file.Path
        End If
    Next file
    
    ' ファイルパスを返す
    findFlag = fileList.count > 0
    Set GetExcelFiles = fileList
End Function


' チェック名前を指定して取得する方法
Function GetCheckBoxValues(wb As Workbook) As Variant()
    Dim chkBox As Object
    Dim chkName As String
    Dim ws As Worksheet
    Dim colSettingsList As Variant
    Dim colSelectList() As Variant
    Dim addCount As Long
    Dim i As Long
    
    Set ws = wb.Sheets("データ結合ツール")
    
    colSettingsList = ws.range("D12:D21").Value
    
    chkName = "ColSelectCheckBox" ' 取得したいチェックボックスの名前

    ' シート上のActiveXコントロールを取得
    addCount = 1
    ReDim colSelectList(1 To 1)
    For i = LBound(colSettingsList) To UBound(colSettingsList)
        On Error GoTo ErrorHandler ' エラー処理
        Set chkBox = ws.OLEObjects(chkName & i)
        On Error GoTo 0 ' エラー処理を元に戻す
        If chkBox.Object.Value = True Then
            ReDim Preserve colSelectList(1 To addCount)
            colSelectList(addCount) = colSettingsList(i, 1)
            addCount = addCount + 1
        End If
    Next i
    
    GetCheckBoxValues = colSelectList
    
    Exit Function
    
ErrorHandler:
    MsgBox "予期せぬエラーが発生しました。管理者へ報告してください。" & vbLf & _
                "エラー箇所:列選択チェックボックス", vbExclamation
    ReDim colSelectList(0)
    colSelectList(0) = "Error"
    GetCheckBoxValues = colSelectList
    Exit Function

End Function

' #############################
' カット設定無効化
' #############################
Private Sub CutOpt_OFF_Click()
    ' 入力
    CutColNameInput.Enabled = False
    CutValueInput.Enabled = False
    CutOverOpt.Enabled = False
    CutUnderOpt.Enabled = False
    ' ラベル
    CutColNameLabel.Enabled = False
    CutValueLabel.Enabled = False
    CutColHowToLabel.Enabled = False
End Sub

' #############################
' カット設定有効化
' #############################
Private Sub CutOpt_On_Click()
    ' 入力
    CutColNameInput.Enabled = True
    CutValueInput.Enabled = True
    CutOverOpt.Enabled = True
    CutUnderOpt.Enabled = True
    ' ラベル
    CutColNameLabel.Enabled = True
    CutValueLabel.Enabled = True
    CutColHowToLabel.Enabled = True
End Sub

```

# 列データ挿入ツール
- 別シート：「列データ」を作成する

## ボタンとテキストボックス
1. SelectDataFileBtn
1. DataFilePathInput
1. AddDestinationColInput
1. DataAddSheetInput
1. 挿入列数: E15

注意書き
　※挿入したい列データは左詰めで、シート「列データ」に張り付けてください
 
　注意！データ挿入後はもとに戻せません。必ずバックアップを取ってから実行してください。
 
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3627984/26e53d80-1c27-4e0c-b36c-d51c33e8b707.png)

```vb
Option Explicit
Dim gDataFilePath As String   ' データ挿入先ファイルパス
Dim gAddDestinationCol As Long   ' 挿入先データ列数（１データにつき）
Dim gDataAddSheet As String   ' データ挿入先シート名

' #############################
' 列データを挿入するデータファイル選択
' #############################
Private Sub SelectDataFileBtn_Click()
    Dim filePath As String

    ' FileDialogオブジェクトのインスタンス取得：ファイル選択ダイアログ
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Excelファイルを選択してください"
        .ButtonName = "選択する"
        ' ファイルフィルターの設定（Excelファイルのみ）
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls"
        ' ダイアログの初期フォルダを設定
        .InitialFileName = ThisWorkbook.Path
        ' 複数選択を禁止
        .AllowMultiSelect = False

        ' ダイアログを表示（キャンセル：処理抜け）
        If Not .Show Then Exit Sub
        
        ' 選択したファイルのフルパスを取得
        filePath = .SelectedItems(1)
    End With

    ' ' 選択したファイルパスをテキストボックスに設定
    DataFilePathInput.Text = filePath
End Sub

' #############################
' 列データ挿入処理（メイン処理）
' #############################
Private Sub ExecuteBtn_Click()
    Dim inputFail As Boolean
    Dim dataWb As Workbook
    Dim dataWs As Worksheet
    Dim dataCount As Long
    Dim addDataWs As Worksheet
    Dim settingsWs As Worksheet
    Dim addDataLastCol As Long
    Dim rc As Integer
    Dim i As Long
    Dim wb As Workbook
    Dim addCountRng As range
    Dim addColList() As Long
    Dim dataLastCol As Long
    Dim addCount As Long
    Dim addCol As Long
    Dim j As Long
    Dim dataLastRow As Long
    Dim deleteRng As range
    
    ' 入力情報取得
    gDataFilePath = DataFilePathInput.Text
    gAddDestinationCol = AddDestinationColInput.Text
    gDataAddSheet = DataAddSheetInput.Text
    
    ' 入力データチェック
    inputFail = InputChk
    
    If inputFail Then
        GoTo endProccess
    End If
    
    Call vbaSpeedUpStart
    
    ' 挿入する列データのシートを取得
    Set wb = ThisWorkbook
    Set addDataWs = wb.Sheets("列データ")
    Set settingsWs = wb.Sheets("列データ挿入ツール")
    addDataLastCol = addDataWs.Cells(2, Columns.count).End(xlToLeft).Column
    
    For i = 1 To addDataLastCol
        ReDim Preserve addColList(i)
        addColList(i) = settingsWs.range("E15").Offset(i - 1, 0).Value
    Next i
    
    ' データ挿入するExcelファイルを開く
    Set dataWb = Workbooks.Open(gDataFilePath)
    Set dataWs = dataWb.Sheets(gDataAddSheet)
    
    dataLastCol = dataWs.Cells(2, Columns.count).End(xlToLeft).Column   ' 2行目の最終列

    ' データチェック
    If dataLastCol Mod gAddDestinationCol <> 0 Then
        rc = MsgBox("挿入先データの最終列が挿入先データ列数（１データにつき）で割り切れません。処理を続けてよろしいですか？", vbYesNo + vbQuestion)
        If rc = vbNo Then
            GoTo endProccess
        End If
    End If
    
    ' 挿入する表データ数を取得
    dataCount = dataLastCol / gAddDestinationCol
    addCount = 0        ' 挿入カウント
    addCol = 0
    For i = 0 To dataCount - 1
        dataLastRow = dataWs.Cells(Rows.count, 1 + i * (gAddDestinationCol + addCount)).End(xlUp).Row
        For j = 1 To UBound(addColList)
            ' データ列挿入処理
            addDataWs.Columns(j).Copy
            addCol = addColList(j) + (addCount + (gAddDestinationCol * i))
            dataWs.Columns(addCol).Insert Shift:=xlToRight
            ' 必要ないデータのカット
            Set deleteRng = dataWs.range(dataWs.Cells(dataLastRow + 1, addCol), dataWs.Cells(Rows.count, addCol))
            deleteRng.ClearContents
            addCount = addCount + 1
        Next j
    Next i
    
    Call vbaSpeedUpEnd
    
    MsgBox "処理が完了しました。", vbInformation, "完了"
    
endProccess:
    Call vbaSpeedUpEnd
    Exit Sub
End Sub

' #############################
' 入力項目を確認
' #############################
Function InputChk() As Boolean
    ' ファイルが存在するかチェック
    If Dir(gDataFilePath) = "" Then
        MsgBox "指定されたファイルが見つかりません: " & gDataFilePath, vbExclamation
        InputChk = True
    ' データ挿入先シート名チェック
    ElseIf Not WorksheetExists(gDataAddSheet) Then
        MsgBox "入力されたデータ挿入先シートが存在しません。", vbExclamation
        InputChk = True
    ' 挿入先データ列数（１データにつき）チェック
    ElseIf Not IsNumeric(gAddDestinationCol) And gAddDestinationCol = 0 Then
        MsgBox "入力された値が無効です。挿入先データ列数には整数を入力してください。", vbExclamation
        InputChk = True
    End If
End Function


' シート存在チェック
Function WorksheetExists(sheetName As String) As Boolean
    Dim wb As Workbook
    Dim ws As Worksheet
    ' データ挿入するExcelファイルを開く
    Set wb = Workbooks.Open(gDataFilePath)
    On Error Resume Next ' エラーを無視
    Set ws = wb.Sheets(sheetName) ' シートを取得
    If Not ws Is Nothing Then
        WorksheetExists = Not ws Is Nothing ' シートが存在するか判定
    Else
        wb.Close
    End If
    
    On Error GoTo 0  ' エラーハンドリングを戻す
End Function

Sub vbaSpeedUpStart()
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .Cursor = xlWait
    End With
 
End Sub

Sub vbaSpeedUpEnd()
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .Cursor = xlDefault
    End With

End Sub

```

# グラフ作成ツール

## ボタンとテキストボックス
1. SelectDataFileBtn
1. DataFilePathInput
1. AddDestinationColInput
1. DataAddSheetInput
1. TableStartRowInput
1. 挿入列数: D18

注意書き
　※複数列で１つのグラフを作りたい場合は「,」(コンマ)区切りで列数を指定してください

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3627984/d3b25aad-17ee-4942-af5f-4701d0bfd3fb.png)


```vb
Option Explicit
Dim gDataFilePath As String   ' グラフ作成先ファイルパス
Dim gAddDestinationCol As Long   ' グラフ作成先データ列数（１データにつき）
Dim gDataAddSheet As String   ' グラフ作成先シート名
Dim gTableStartRow As Long     ' グラフ作成先シートのタイトル行

' #############################
' グラフ作成するデータファイル選択
' #############################
Private Sub SelectDataFileBtn_Click()
    Dim filePath As String

    ' FileDialogオブジェクトのインスタンス取得：ファイル選択ダイアログ
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Excelファイルを選択してください"
        .ButtonName = "選択する"
        ' ファイルフィルターの設定（Excelファイルのみ）
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls"
        ' ダイアログの初期フォルダを設定
        .InitialFileName = ThisWorkbook.Path
        ' 複数選択を禁止
        .AllowMultiSelect = False

        ' ダイアログを表示（キャンセル：処理抜け）
        If Not .Show Then Exit Sub
        
        ' 選択したファイルのフルパスを取得
        filePath = .SelectedItems(1)
    End With

    ' 選択したファイルパスをテキストボックスに設定
    DataFilePathInput.Text = filePath
End Sub


' #############################
' 列データ挿入処理（メイン処理）
' #############################
Private Sub ExecuteBtn_Click()
    Dim wb As Workbook
    Dim settingsWs As Worksheet
    Dim inputFail As Boolean
    Dim dataWb As Workbook
    Dim dataWs As Worksheet
    Dim graphSettingList As Variant
    Dim dataLastCol As Long
    Dim rc As Integer
    Dim dataCount As Long
    Dim graphSettingsRow As Long
    Dim startCol As Long
    
    Set wb = ThisWorkbook
    Set settingsWs = wb.Sheets("グラフ作成ツール")
    
    ' 入力情報取得
    gDataFilePath = DataFilePathInput.Text
    gAddDestinationCol = AddDestinationColInput.Text
    gDataAddSheet = DataAddSheetInput.Text
    gTableStartRow = TableStartRowInput.Text
    
    ' 入力データチェック
    inputFail = InputChk
    
    If inputFail Then
        GoTo endProccess
    End If
    
    Call vbaSpeedUpStart
    
    ' データ挿入するExcelファイルを開く
    Set dataWb = Workbooks.Open(gDataFilePath)
    Set dataWs = dataWb.Sheets(gDataAddSheet)
    
    dataLastCol = dataWs.Cells(2, Columns.count).End(xlToLeft).Column   ' 2行目の最終列
    
    ' データチェック
    If dataLastCol Mod gAddDestinationCol <> 0 Then
        rc = MsgBox("挿入先データの最終列が挿入先データ列数（１データにつき）で割り切れません。処理を続けてよろしいですか？", vbYesNo + vbQuestion)
        If rc = vbNo Then
            GoTo endProccess
        End If
    End If
    
    ' 表データの数を算出
    dataCount = dataLastCol / gAddDestinationCol
    
    ' 作成グラフ設定読み取り
    graphSettingsRow = settingsWs.Range("D18").End(xlDown).Row
    graphSettingList = settingsWs.Range("D18:F" & graphSettingsRow).Value
    
    Dim i As Long
    Dim j As Long
    Dim count As Long
    Dim dataLastRow As Long
    Dim createColArray As Variant
    
    For i = 0 To dataCount - 1
        ' 範囲指定最終行
        startCol = 1 + i * gAddDestinationCol
        dataLastRow = dataWs.Cells(Rows.count, startCol).End(xlUp).Row
        For j = LBound(graphSettingList, 1) To UBound(graphSettingList, 1)
            ' 範囲指定列
            If InStr(1, graphSettingList(j, 2), ",") > 0 Then
                createColArray = Split(graphSettingList(j, 2), ",")
            Else
                ReDim createColArray(0)
                createColArray(0) = graphSettingList(j, 2)
            End If
            
            For count = LBound(createColArray) To UBound(createColArray)
                createColArray(count) = createColArray(count) + gAddDestinationCol * i
            Next count
            Call CreateScatterChartMultipleY(dataLastRow, startCol, createColArray, graphSettingList, j, dataWs)
        Next j
    Next i
    
endProccess:
    Call vbaSpeedUpEnd
    Exit Sub
End Sub



' #############################
' 入力項目を確認
' #############################
Function InputChk() As Boolean
    ' ファイルが存在するかチェック
    If Dir(gDataFilePath) = "" Then
        MsgBox "指定されたファイルが見つかりません: " & gDataFilePath, vbExclamation
        InputChk = True
    ' データ挿入先シート名チェック
    ElseIf Not WorksheetExists(gDataAddSheet) Then
        MsgBox "入力されたデータ挿入先シートが存在しません。", vbExclamation
        InputChk = True
    ' 挿入先データ列数（１データにつき）チェック
    ElseIf Not IsNumeric(gAddDestinationCol) And gAddDestinationCol = 0 Then
        MsgBox "入力された値が無効です。挿入先データ列数には整数を入力してください。", vbExclamation
        InputChk = True
    End If
    
End Function


' #############################
' グラフ作成処理 複数軸
' #############################
Sub CreateScatterChartMultipleY(dataLastRow As Long, xCol As Long, yColArray As Variant, graphSettingList As Variant, settingsIndex As Long, dataWs As Worksheet)
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim scatterChart As Chart
    Dim xRange As Range
    Dim yRange As Range
    Dim outputPointCell As Range
    Dim dataStartRow As Long
    Dim yCol As Long
    Dim i As Long
    ' シートを指定（適宜変更）
    Set ws = dataWs
    
    ' 出力位置を取得
    Set outputPointCell = ws.Cells(graphSettingList(settingsIndex, 3), xCol)
    
    ' グラフオブジェクトを追加
    Set chartObj = ws.ChartObjects.Add(Left:=outputPointCell.Left, Top:=outputPointCell.Top, Width:=360, Height:=216)
    Set scatterChart = chartObj.Chart
    
    ' グラフの種類を散布図（直線）に設定
    scatterChart.ChartType = xlXYScatterLines
    
    ' X軸のデータ範囲を指定
    dataStartRow = gTableStartRow + 1       ' データ開始行
    Set xRange = ws.Range(ws.Cells(dataStartRow, xCol), ws.Cells(dataLastRow, xCol)) ' X軸の範囲
    
    For i = LBound(yColArray) To UBound(yColArray)
        yCol = CInt(yColArray(i))
        Set yRange = ws.Range(ws.Cells(dataStartRow, yCol), ws.Cells(dataLastRow, yCol)) ' Y軸1の範囲
        
        ' ---- Y軸のデータ追加 ----
        With scatterChart.SeriesCollection.NewSeries
            .XValues = xRange ' X軸データ
            .Values = yRange ' Y軸データ
            .Name = ws.Cells(gTableStartRow, yCol).Value
        End With
    Next i
    
    ' グラフのタイトルを設定
    scatterChart.HasTitle = True
    scatterChart.ChartTitle.Text = graphSettingList(settingsIndex, 1)
    
    ' 書式設定
    With chartObj.Chart
        .ChartArea.Font.Name = "Meiryo UI"
        .HasTitle = True
        With .ChartTitle.Format.TextFrame2.TextRange.Font
            .Bold = msoFalse
            .Size = 14
        End With
    End With
    
    ' 軸ラベルを設定
'    With scatterChart.Axes(xlCategory)
'        .HasTitle = True
'        .AxisTitle.Text = "X軸（項目）"
'    End With
'    With scatterChart.Axes(xlValue)
'        .HasTitle = True
'        .AxisTitle.Text = "Y軸（値）"
'    End With

    ' 凡例を表示
    scatterChart.HasLegend = True
    
    ' オブジェクトの解放
    Set ws = Nothing
    Set chartObj = Nothing
    Set scatterChart = Nothing
    Set xRange = Nothing
    Set yRange = Nothing
End Sub

' シート存在チェック
Function WorksheetExists(sheetName As String) As Boolean
    Dim wb As Workbook
    Dim ws As Worksheet
    ' データ挿入するExcelファイルを開く
    Set wb = Workbooks.Open(gDataFilePath)
    On Error Resume Next ' エラーを無視
    Set ws = wb.Sheets(sheetName) ' シートを取得
    If Not ws Is Nothing Then
        WorksheetExists = Not ws Is Nothing ' シートが存在するか判定
    Else
        wb.Close
    End If
    
    On Error GoTo 0  ' エラーハンドリングを戻す
End Function

Sub vbaSpeedUpStart()
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .Cursor = xlWait
    End With
 
End Sub

Sub vbaSpeedUpEnd()
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .Cursor = xlDefault
    End With

End Sub
```

メモ
```
ツール
探索行
　-カット電圧
　-負極電位
　-soc80%

フォルダ構成
-温度⚪︎
　-カット電圧⚪︎.⚪︎
　　-Cレート⚪︎
　　-Cレート⚪︎
　-カット電圧⚪︎.⚪︎
　　-Cレート⚪︎
　　-Cレート⚪︎

アイディア
　-選択フォルダ含めて3つ目のフォルダ内のtable1読み取り
　-フォルダ名出力でどの値か分かる
　-三行抜き出す関数作成

 出力行作成クラス
main関数
　
```