データ結合ツール
複数のExcelファイルのデータを１つのファイルにまとめる
ボタン
- SelectFolderOpt
- SubFolderOpt
- DataFolderPathInput
- SelectDataFolderBtn
- ColSelectCheckBox1~x
- CutOpt_On
- CutOpt_OFF
- CutColNameLabel
- CutColNameInput
- CutValueLabel
- CutValueInput
- CutColHowToLabel
- CutOverOpt
- CutUnderOpt
- ExecuteBtn
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
列データ挿入ツール
- 別シート：「列データ」を作成する
ボタンとテキストボックス
- SelectDataFileBtn
- DataFilePathInput
- AddDestinationColInput
- DataAddSheetInput
- 挿入列数: E15
注意書き
※挿入したい列データは左詰めで、シート「列データ」に張り付けてください
注意！データ挿入後はもとに戻せません。必ずバックアップを取ってから実行してください。
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
グラフ作成ツール
ボタンとテキストボックス
- SelectDataFileBtn
- DataFilePathInput
- AddDestinationColInput
- DataAddSheetInput
- TableStartRowInput
- 挿入列数: D18
注意書き
※複数列で１つのグラフを作りたい場合は「,」(コンマ)区切りで列数を指定してください
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