vba：EXCELSQL（エラー出力を実装）
sheet1
Sub SetData()
' 画面を初期化
Rows("1:19").Select
Selection.Delete Shift:=xlUp
' 列の選択状態を解除
Sheet1.Range("A1").Select
' 実行ボタンを生成
With ActiveSheet.Buttons.Add(Range("B5").Left, _
Range("B5").Top, _
Range("B5:D5").Width, _
Range("B5:D6").Height)
.Name = "btn"
.OnAction = "Sheet1.MakeMaxValueTable"
.Characters.Text = "exe"
End With
' テストデータを出力
Dim arr_id_data As Variant: arr_id_data = Array("e_01", "e_02", "e_03", "e_04", "e_05", "e_06", "e_07", "e_08", "e_09", "e_10")
Dim arr_val_data As Variant: arr_val_data = Array(1000, 1300, 800, 1100, 700, 1000, 2100, 1100, 500, 800)
For r = 0 To UBound(arr_id_data)
Cells(r + 9, 2).Value = arr_id_data(r)
Cells(r + 9, 3).Value = arr_val_data(r)
Next r
' ヘッダーを設定
Sheet1.Range("B8").Value = "ID"
Sheet1.Range("C8:C8").Value = "Value"
Sheet1.Range("E8").Value = "閾値"
' 閾値を設定
Sheet1.Range("E9").Value = 800
' *** 全体的な見た目の設定 ****
Call SetFormat(Sheet1, Sheet1.Range("B8:C8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("B9:B18"), "id")
Call SetFormat(Sheet1, Sheet1.Range("C9:C18"), "val")
Call SetFormat(Sheet1, Sheet1.Range("E8:E8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("E9:E9"), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
End Sub
' 最大値を抽出し強調表示する
Sub MakeMaxValueTable()
On Error GoTo ErrorHandler
' =====================
' 開始処理
' =====================
Dim comUtil As CommonUtil
Set comUtil = New CommonUtil
comUtil.ExeInit
'err.Raise 513
'画面初期化
' 条件付き書式をクリア
Dim ws As Worksheet
For Each ws In Worksheets
ws.Cells.FormatConditions.Delete
Next ws
' グラフをクリア
With Sheet1
' 実行結果出力範囲をクリア
.Rows("2:3").Clear
Dim r As Long
For r = .ChartObjects.Count To 1 Step -1
.ChartObjects(r).Delete
Next r
End With
' =====================
' 入力チェック
' =====================
'リストの値を取得して、配列に格納
Dim arr_ori As Variant: arr_ori = Sheet1.Range("B9:C18").Value
' 閾値を取得
Dim line_val As Long: line_val = Sheet1.Range("E9").Value
' 最大値を取得
Dim max_val As Long: max_val = Application.WorksheetFunction.Max(arr_ori)
' 最大値 <= 閾値は処理終了
If (max_val <= line_val) Then
Dim rc As Integer
rc = MsgBox("閾値は最大値より小さい値を設定してください。" & vbCrLf & "最大値：" & max_val, vbOKOnly + vbExclamation)
If rc = vbOK Then
Exit Sub
End If
End If
' =====================
' コネクションOPEN
' =====================
' 処理対象ファイルのフルパス
Dim fileFullName As String: fileFullName = ThisWorkbook.FullName
Dim dbUtil As DatabaseUtil
Set dbUtil = New DatabaseUtil
If Not dbUtil.IsConnectedDB("excelsql", fileFullName) Then
' エラーログをtxtに出力する処理を追加する
Debug.Print "システムエラー：DB接続に失敗しました。"
Exit Sub
End If
' =====================
' SQLを作成して実行
' =====================
Dim sqlStr As String
' ' シート名のパラメータ化が必要
' sqlStr = ""
' sqlStr = sqlStr & " select"
' sqlStr = sqlStr & " *"
' sqlStr = sqlStr & " from"
' sqlStr = sqlStr & " [Sheet1$]"
' sqlStr = sqlStr & " where"
' sqlStr = sqlStr & " Value > " & line_val
sqlStr = "select * from [Sheet1$] where Value > " & line_val
Set rs = dbUtil.ExeSelect(sqlStr)
' =====================
' SQL実行結果出力
' =====================
' 抽出結果を出力・・・縦
' Sheet1.Range("G2").CopyFromRecordset rs
' 抽出結果を出力・・・横
Dim fieldCnt As Long: fieldCnt = rs.Fields.Count
Dim recordCnt As Long: recordCnt = rs.RecordCount
' これで、横に格納してるみたいです
'ReDim recordArray(fieldCnt, recordCnt) As Variant: recordArray = rs.GetRows
'シートに出力
' 横に出力する場合は、起点のセルだけ指定だとうまくいかないみたいなので、出力するRangeを指定する。
'Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = recordArray
' 抽出結果で特に何もしないなら、直接設定する方が良い
Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = rs.GetRows
' =====================
' 最大値の設定
' =====================
Dim fc As FormatCondition
' range・・・入れ子だと見辛いので、変数に格納
Dim resultDataRange As Range: Set resultDataRange = Sheet1.Range(Cells(3, 2), Cells(fieldCnt, recordCnt + 1))
' 条件付き書式を生成・・・入れ子だと見辛いので、変数に格納（.Addressの絶対参照を忘れないこと）
' MAX関数は、最大値が複数ある場合は、存在するだけ最大値と判定します
Dim strFormula As String: strFormula = "=B3=MAX(" & resultDataRange.Address & ")"
Set fc = resultDataRange.FormatConditions.Add( _
Type:=xlExpression, _
Formula1:=strFormula)
' 最大値の見た目を設定
fc.Interior.Color = RGB(255, 0, 0)
fc.Font.Color = RGB(255, 255, 255)
fc.Font.Bold = True
' =====================
' グラフを生成
' =====================
Call MakeChart(Sheet1, fieldCnt, recordCnt, line_val)
' =====================
' 全体的な見た目の設定
' =====================
Call SetFormat(Sheet1, Sheet1.Range(Cells(2, 2), Cells(2, recordCnt + 1)), "id")
Call SetFormat(Sheet1, Sheet1.Range(Cells(3, 2), Cells(3, recordCnt + 1)), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
'Finally:へ飛ぶ
GoTo Finally
ErrorHandler:
'エラーメッセージを表示する
' MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical & vbOKOnly, "エラー"
Dim logUtil As logUtil
Set logUtil = New logUtil
Call logUtil.OutputErrorLog(err)
' If err.Number <> 0 Then
' ' クリアしないとループするみたいなので、クリアする
' err.Clear
' End If
'Finally:へ飛ぶ
Resume Finally
Finally:
If Not err Is Nothing Then
err.Clear
End If
comUtil.ExeFinal
End Sub
' 書式を設定
' 項目：id 、値:val
Sub SetFormat(ByVal sh As Worksheet, ByVal rng As Range, ByVal item As String)
sh.Select
rng.Select
With Selection
' 外枠の設定・・・ちなみにこれは、中太
'.BorderAround Weight:=xlMedium
.Borders.LineStyle = True
Select Case item
Case "id"
.HorizontalAlignment = xlCenter
.Interior.Color = rgbTurquoise
Case "val"
.NumberFormatLocal = "#,###"
End Select
End With
End Sub
' グラフを生成
Sub MakeChart(ByVal sh As Worksheet, ByVal fieldCnt As Long, ByVal recordCnt As Long, ByVal line_val As Long)
sh.Select
' 配列に入れなおさないとうまくいかないので、入れなおす。（この辺は、要検証）
Dim arr_ans() As Variant: arr_ans = Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1))
' グラフ生成用に、ヘッダーと値の配列を作成
Dim arr_header As Variant: arr_header = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 1, 0))
Dim arr_val As Variant: arr_val = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 2, 0))
Dim co As ChartObject
' グラフの外枠？を設置
Set co = ActiveSheet.ChartObjects.Add(Left:=Range("G8").Left, Top:=Range("G8").Top, Width:=324, Height:=206)
' グラフの中身を生成
With co
With .Chart.SeriesCollection.NewSeries
.Name = "Value"
.Values = arr_val
.XValues = arr_header
End With
End With
With co.Chart
'グラフ形式を設定
co.Chart.ChartType = xlColumnClustered
'凡例非表示
co.Chart.HasLegend = True
' グラフの左線を強調（線の太さと色・・・結構見やすいかも）
.Axes(xlValue).format.Line.Weight = 2
.Axes(xlValue).format.Line.ForeColor.RGB = RGB(0, 0, 0)
' グラフの下線を強調
.Axes(xlCategory).format.Line.Weight = 2
.Axes(xlCategory).format.Line.ForeColor.RGB = RGB(0, 0, 0)
'基準線を新規系列として追加
With .SeriesCollection.NewSeries
.Name = "=""閾値""" '特に必要はない
.Values = "={" & Join(Array(line_val, line_val), ",") & "}"
.ChartType = xlLine '折れ線
.AxisGroup = 2 '第2軸
.format.Line.ForeColor.RGB = vbRed 'RGB(255, 0, 0)
End With
'第2縦軸のScaleを第1縦軸に合わせる
.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
.Axes(xlValue, 2).Delete '第2軸を消す
'グラフ内左右余白を消す：基準線を第2横軸に設定
.HasAxis(xlCategory, 2) = True '第2横軸表示
.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
End With
End Sub
CommonUtil
Option Explicit
Public Sub ExeInit()
With ActiveWorkbook.Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
End Sub
Public Sub ExeFinal()
With ActiveWorkbook.Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Public Function ConvertDateToString(ByVal dt As Date, ByVal formatNo As Long) As String
Select Case formatNo
Case 1
ConvertDateToString = format(dt, "yyyymmdd")
End Select
End Function
DatabaseUtil
Option Explicit
Private cn As ADODB.Connection
Private rs As ADODB.Recordset
'-------------------------------------------------------------------------------------
' コンストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_initialize()
If Not rs Is Nothing Then rs.Close
End Sub
'-------------------------------------------------------------------------------------
' デストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_terminate()
On Error Resume Next
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
'-------------------------------------------------------------------------------------
' データベース接続
'【引数】DBType 接続するDBを指定
' excelsql … Excelをデータベースとして接続
'【戻値】接続成功：True ／ 接続失敗：False（Boolean）
'-------------------------------------------------------------------------------------
Public Function IsConnectedDB(ByVal useDb As String, ByVal fileFullName As String) As Boolean
Dim ConnectingString As String
Select Case useDb
Case "excelsql"
ConnectingString = "PROVIDER = MSDASQL; Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; " & "DBQ=" & fileFullName & "; ReadOnly=False;"
Case Else
GoTo ErrHandler
End Select
On Error GoTo ErrHandler
Set cn = New ADODB.Connection
cn.ConnectionString = ConnectingString
cn.ConnectionTimeout = 2
cn.Open
IsConnectedDB = True
Exit Function
ErrHandler:
IsConnectedDB = False
End Function
'-------------------------------------------------------------------------------------
' SQL文を実行する（Select 文）
'【引数】strSQL SQL文
'【戻値】Recordset オブジェクト
'-------------------------------------------------------------------------------------
Public Function ExeSelect(ByVal strSQL As String) As ADODB.Recordset
Set rs = New ADODB.Recordset
'SQL文実行（読み取り専用、共有ロック）
rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
Set ExeSelect = rs
End Function
'-------------------------------------------------------------------------------------
' SQL文を実行する（Insert into文、Delete 文など）
'【引数】strSQL SQL文（String）
'【戻値】変更されたレコード数（Long）
'-------------------------------------------------------------------------------------
Public Function ExeUpdate(strSQL As String) As Long
Dim updateCnt As Long
cn.Execute strSQL, updateCnt
ExeUpdate = updateCnt
End Function
'-------------------------------------------------------------------------------------
'トランザクション開始
'-------------------------------------------------------------------------------------
Public Sub BeginTr()
cn.BeginTrans
End Sub
'-------------------------------------------------------------------------------------
' トランザクションコミット
'-------------------------------------------------------------------------------------
Public Sub CommitTr()
cn.CommitTrans
End Sub
'-------------------------------------------------------------------------------------
' トランザクションロールバック
'-------------------------------------------------------------------------------------
Public Sub RollbackTr()
cn.RollbackTrans
End Sub
LogUtil
Option Explicit
'-----------------------------------------------------
' エラーログをファイルに出力する
' 出力先は、実行ファイルと同様のフォルダ、出力先のフォルダが無い場合は、生成する。
' 出力ファイ名：yyyymmdd_error.log ※日付は、出力当日
'
' 引数：エラーオブジェクト
'
'-----------------------------------------------------
Public Sub OutputErrorLog(ByVal err As ErrObject)
Dim comUtil As CommonUtil
Set comUtil = New CommonUtil
' ファイル名から拡張子を削除→フォルダ名
Dim logFolderName As String: logFolderName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
' 実行当日からファイル用の日付を抽出し、ファイル名を生成
Dim logFileName As String: logFileName = comUtil.ConvertDateToString(Now, 1) & "_error.log"
Dim folderPath As String: folderPath = ThisWorkbook.Path & "\" & logFolderName
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダが無い場合、生成
If Dir(folderPath, vbDirectory) = "" Then fso.CreateFolder (folderPath)
Dim strPath As String: strPath = ThisWorkbook.Path & "\" & logFolderName & "\" & logFileName
Dim logMsg As String: logMsg = Now & vbTab & "NO:" & err.Number & vbTab & "DESC:" & err.Description
' エラー内容を出力
With fso
If Not .FileExists(strPath) Then
.CreateTextFile (strPath)
End If
With .OpenTextFile(strPath, 8)
.WriteLine logMsg
.Close
End With
End With
Set fso = Nothing
End Sub
vba：CommonUtil
- 呼び出しは、こんな感じ
' =====================
' 開始処理
' =====================
Dim comUtil As CommonUtil
Set comUtil = New CommonUtil
comUtil.ExeInit
- クラス：CommonUtilで実装
Option Explicit
Public Sub ExeInit()
With ActiveWorkbook.Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
End Sub
Public Sub ExeFinal()
With ActiveWorkbook.Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Public Function ConvertDateToString(ByVal dt As Date, ByVal formatNo As Long) As String
Select Case formatNo
Case 1
ConvertDateToString = format(dt, "yyyymmdd")
End Select
End Function
vba：エラー処理
- クラス：LogUtilで実装
- エラーまでをがっつり実装するメリットがあまりない気がする。
Option Explicit
'-----------------------------------------------------
' エラーログをファイルに出力する
' 出力先は、実行ファイルと同様のフォルダ、出力先のフォルダが無い場合は、生成する。
' 出力ファイ名：yyyymmdd_error.log ※日付は、出力当日
'
' 引数：エラーオブジェクト
'
'-----------------------------------------------------
Public Sub OutputErrorLog(ByVal err As ErrObject)
Dim comUtil As CommonUtil
Set comUtil = New CommonUtil
' ファイル名から拡張子を削除→フォルダ名
Dim logFolderName As String: logFolderName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
' 実行当日からファイル用の日付を抽出し、ファイル名を生成
Dim logFileName As String: logFileName = comUtil.ConvertDateToString(Now, 1) & "_error.log"
Dim folderPath As String: folderPath = ThisWorkbook.Path & "\" & logFolderName
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダが無い場合、生成
If Dir(folderPath, vbDirectory) = "" Then fso.CreateFolder (folderPath)
Dim strPath As String: strPath = ThisWorkbook.Path & "\" & logFolderName & "\" & logFileName
Dim logMsg As String: logMsg = Now & vbTab & "NO:" & err.Number & vbTab & "DESC:" & err.Description
' エラー内容を出力
With fso
If Not .FileExists(strPath) Then
.CreateTextFile (strPath)
End If
With .OpenTextFile(strPath, 8)
.WriteLine logMsg
.Close
End With
End With
Set fso = Nothing
End Sub
vba：EXCELSQL（DBconnectionを部品化）
- こちらのサイトを参考にさせていただきました。
Sub SetData()
' 画面を初期化
Rows("1:19").Select
Selection.Delete Shift:=xlUp
' 列の選択状態を解除
Sheet1.Range("A1").Select
' 実行ボタンを生成
With ActiveSheet.Buttons.Add(Range("B5").Left, _
Range("B5").Top, _
Range("B5:D5").Width, _
Range("B5:D6").Height)
.Name = "btn"
.OnAction = "Sheet1.MakeMaxValueTable"
.Characters.Text = "exe"
End With
' テストデータを出力
Dim arr_id_data As Variant: arr_id_data = Array("e_01", "e_02", "e_03", "e_04", "e_05", "e_06", "e_07", "e_08", "e_09", "e_10")
Dim arr_val_data As Variant: arr_val_data = Array(1000, 1300, 800, 1100, 700, 1000, 2100, 1100, 500, 800)
For r = 0 To UBound(arr_id_data)
Cells(r + 9, 2).Value = arr_id_data(r)
Cells(r + 9, 3).Value = arr_val_data(r)
Next r
' ヘッダーを設定
Sheet1.Range("B8").Value = "ID"
Sheet1.Range("C8:C8").Value = "Value"
Sheet1.Range("E8").Value = "閾値"
' 閾値を設定
Sheet1.Range("E9").Value = 800
' *** 全体的な見た目の設定 ****
Call SetFormat(Sheet1, Sheet1.Range("B8:C8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("B9:B18"), "id")
Call SetFormat(Sheet1, Sheet1.Range("C9:C18"), "val")
Call SetFormat(Sheet1, Sheet1.Range("E8:E8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("E9:E9"), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
End Sub
' 最大値を抽出し強調表示する
Sub MakeMaxValueTable()
' =====================
' 開始処理
' =====================
' 結果表示時のちらつきが気持ち悪いので、非表示
Application.ScreenUpdating = False
'画面初期化
' 条件付き書式をクリア
Dim ws As Worksheet
For Each ws In Worksheets
ws.Cells.FormatConditions.Delete
Next ws
' グラフをクリア
With Sheet1
' 実行結果出力範囲をクリア
.Rows("2:3").Clear
Dim r As Long
For r = .ChartObjects.Count To 1 Step -1
.ChartObjects(r).Delete
Next r
End With
' =====================
' 入力チェック
' =====================
'リストの値を取得して、配列に格納
Dim arr_ori As Variant: arr_ori = Sheet1.Range("B9:C18").Value
' 閾値を取得
Dim line_val As Long: line_val = Sheet1.Range("E9").Value
' 最大値を取得
Dim max_val As Long: max_val = Application.WorksheetFunction.Max(arr_ori)
' 最大値 <= 閾値は処理終了
If (max_val <= line_val) Then
Dim rc As Integer
rc = MsgBox("閾値は最大値より小さい値を設定してください。" & vbCrLf & "最大値：" & max_val, vbOKOnly + vbExclamation)
If rc = vbOK Then
Exit Sub
End If
End If
' =====================
' コネクションOPEN
' =====================
' 処理対象ファイルのフルパス
Dim fileFullName As String: fileFullName = ThisWorkbook.FullName
Dim dbCon As DBconnection
Set dbCon = New DBconnection
If Not dbCon.IsConnectedDB("excelsql", fileFullName) Then
' エラーログをtxtに出力する処理を追加する
Debug.Print "システムエラー：DB接続に失敗しました。"
Exit Sub
End If
' =====================
' SQLを作成して実行
' =====================
Dim sqlStr As String
' ' シート名のパラメータ化が必要
' sqlStr = ""
' sqlStr = sqlStr & " select"
' sqlStr = sqlStr & " *"
' sqlStr = sqlStr & " from"
' sqlStr = sqlStr & " [Sheet1$]"
' sqlStr = sqlStr & " where"
' sqlStr = sqlStr & " Value > " & line_val
sqlStr = "select * from [Sheet1$] where Value > " & line_val
Set rs = dbCon.ExeSelect(sqlStr)
' =====================
' SQL実行結果出力
' =====================
' 抽出結果を出力・・・縦
' Sheet1.Range("G2").CopyFromRecordset rs
' 抽出結果を出力・・・横
Dim fieldCnt As Long: fieldCnt = rs.Fields.Count
Dim recordCnt As Long: recordCnt = rs.RecordCount
' これで、横に格納してるみたいです
'ReDim recordArray(fieldCnt, recordCnt) As Variant: recordArray = rs.GetRows
'シートに出力
' 横に出力する場合は、起点のセルだけ指定だとうまくいかないみたいなので、出力するRangeを指定する。
'Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = recordArray
' 抽出結果で特に何もしないなら、直接設定する方が良い
Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = rs.GetRows
' =====================
' 最大値の設定
' =====================
Dim fc As FormatCondition
' range・・・入れ子だと見辛いので、変数に格納
Dim resultDataRange As Range: Set resultDataRange = Sheet1.Range(Cells(3, 2), Cells(fieldCnt, recordCnt + 1))
' 条件付き書式を生成・・・入れ子だと見辛いので、変数に格納（.Addressの絶対参照を忘れないこと）
' MAX関数は、最大値が複数ある場合は、存在するだけ最大値と判定します
Dim strFormula As String: strFormula = "=B3=MAX(" & resultDataRange.Address & ")"
Set fc = resultDataRange.FormatConditions.Add( _
Type:=xlExpression, _
Formula1:=strFormula)
' 最大値の見た目を設定
fc.Interior.Color = RGB(255, 0, 0)
fc.Font.Color = RGB(255, 255, 255)
fc.Font.Bold = True
' =====================
' グラフを生成
' =====================
Call MakeChart(Sheet1, fieldCnt, recordCnt, line_val)
' =====================
' 全体的な見た目の設定
' =====================
Call SetFormat(Sheet1, Sheet1.Range(Cells(2, 2), Cells(2, recordCnt + 1)), "id")
Call SetFormat(Sheet1, Sheet1.Range(Cells(3, 2), Cells(3, recordCnt + 1)), "val")
' =====================
' 終了処理
' =====================
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
Application.ScreenUpdating = True
End Sub
' 書式を設定
' 項目：id 、値:val
Sub SetFormat(ByVal sh As Worksheet, ByVal rng As Range, ByVal item As String)
sh.Select
rng.Select
With Selection
' 外枠の設定・・・ちなみにこれは、中太
'.BorderAround Weight:=xlMedium
.Borders.LineStyle = True
Select Case item
Case "id"
.HorizontalAlignment = xlCenter
.Interior.Color = rgbTurquoise
Case "val"
.NumberFormatLocal = "#,###"
End Select
End With
End Sub
' グラフを生成
Sub MakeChart(ByVal sh As Worksheet, ByVal fieldCnt As Long, ByVal recordCnt As Long, ByVal line_val As Long)
sh.Select
' 配列に入れなおさないとうまくいかないので、入れなおす。（この辺は、要検証）
Dim arr_ans() As Variant: arr_ans = Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1))
' グラフ生成用に、ヘッダーと値の配列を作成
Dim arr_header As Variant: arr_header = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 1, 0))
Dim arr_val As Variant: arr_val = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 2, 0))
Dim co As ChartObject
' グラフの外枠？を設置
Set co = ActiveSheet.ChartObjects.Add(Left:=Range("G8").Left, Top:=Range("G8").Top, Width:=324, Height:=206)
' グラフの中身を生成
With co
With .Chart.SeriesCollection.NewSeries
.Name = "Value"
.Values = arr_val
.XValues = arr_header
End With
End With
With co.Chart
'グラフ形式を設定
co.Chart.ChartType = xlColumnClustered
'凡例非表示
co.Chart.HasLegend = True
' グラフの左線を強調（線の太さと色・・・結構見やすいかも）
.Axes(xlValue).Format.Line.Weight = 2
.Axes(xlValue).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
' グラフの下線を強調
.Axes(xlCategory).Format.Line.Weight = 2
.Axes(xlCategory).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
'基準線を新規系列として追加
With .SeriesCollection.NewSeries
.Name = "=""閾値""" '特に必要はない
.Values = "={" & Join(Array(line_val, line_val), ",") & "}"
.ChartType = xlLine '折れ線
.AxisGroup = 2 '第2軸
.Format.Line.ForeColor.RGB = vbRed 'RGB(255, 0, 0)
End With
'第2縦軸のScaleを第1縦軸に合わせる
.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
.Axes(xlValue, 2).Delete '第2軸を消す
'グラフ内左右余白を消す：基準線を第2横軸に設定
.HasAxis(xlCategory, 2) = True '第2横軸表示
.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
End With
End Sub
- DBconnectionクラス
Option Explicit
Private cn As ADODB.Connection
Private rs As ADODB.Recordset
'-------------------------------------------------------------------------------------
' コンストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_initialize()
If Not rs Is Nothing Then rs.Close
End Sub
'-------------------------------------------------------------------------------------
' デストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_terminate()
On Error Resume Next
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
'-------------------------------------------------------------------------------------
' データベース接続
'【引数】DBType 接続するDBを指定
' excelsql … Excelをデータベースとして接続
'【戻値】接続成功：True ／ 接続失敗：False（Boolean）
'-------------------------------------------------------------------------------------
Public Function IsConnectedDB(ByVal useDb As String, ByVal fileFullName As String) As Boolean
Dim ConnectingString As String
Select Case useDb
Case "excelsql"
ConnectingString = "PROVIDER = MSDASQL; Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; " & "DBQ=" & fileFullName & "; ReadOnly=False;"
Case Else
GoTo ErrHandler
End Select
On Error GoTo ErrHandler
Set cn = New ADODB.Connection
cn.ConnectionString = ConnectingString
cn.ConnectionTimeout = 2
cn.Open
IsConnectedDB = True
Exit Function
ErrHandler:
IsConnectedDB = False
End Function
'-------------------------------------------------------------------------------------
' SQL文を実行する（Select 文）
'【引数】strSQL SQL文
'【戻値】Recordset オブジェクト
'-------------------------------------------------------------------------------------
Public Function ExeSelect(ByVal strSQL As String) As ADODB.Recordset
Set rs = New ADODB.Recordset
'SQL文実行（読み取り専用、共有ロック）
rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
Set ExeSelect = rs
End Function
'-------------------------------------------------------------------------------------
' SQL文を実行する（Insert into文、Delete 文など）
'【引数】strSQL SQL文（String）
'【戻値】変更されたレコード数（Long）
'-------------------------------------------------------------------------------------
Public Function ExeUpdate(strSQL As String) As Long
Dim updateCnt As Long
cn.Execute strSQL, updateCnt
ExeUpdate = updateCnt
End Function
'-------------------------------------------------------------------------------------
'トランザクション開始
'-------------------------------------------------------------------------------------
Public Sub BeginTr()
cn.BeginTrans
End Sub
'-------------------------------------------------------------------------------------
' トランザクションコミット
'-------------------------------------------------------------------------------------
Public Sub CommitTr()
cn.CommitTrans
End Sub
'-------------------------------------------------------------------------------------
' トランザクションロールバック
'-------------------------------------------------------------------------------------
Public Sub RollbackTr()
cn.RollbackTrans
End Sub
vba：課題（EXCELSQLバージョン）
EXCELSQLバージョン
Sub SetData()
' 画面を初期化
Rows("1:19").Select
Selection.Delete Shift:=xlUp
' 列の選択状態を解除
Sheet1.Range("A1").Select
' 実行ボタンを生成
With ActiveSheet.Buttons.Add(Range("B5").Left, _
Range("B5").Top, _
Range("B5:D5").Width, _
Range("B5:D6").Height)
.Name = "btn"
.OnAction = "Sheet1.MakeMaxValueTable"
.Characters.Text = "exe"
End With
' テストデータを出力
Dim arr_id_data As Variant: arr_id_data = Array("e_01", "e_02", "e_03", "e_04", "e_05", "e_06", "e_07", "e_08", "e_09", "e_10")
Dim arr_val_data As Variant: arr_val_data = Array(1000, 1300, 800, 1100, 700, 1000, 2100, 1100, 500, 800)
For r = 0 To UBound(arr_id_data)
Cells(r + 9, 2).Value = arr_id_data(r)
Cells(r + 9, 3).Value = arr_val_data(r)
Next r
' ヘッダーを設定
Sheet1.Range("B8").Value = "ID"
Sheet1.Range("C8:C8").Value = "Value"
Sheet1.Range("E8").Value = "閾値"
' 閾値を設定
Sheet1.Range("E9").Value = 800
' *** 全体的な見た目の設定 ****
Call SetFormat(Sheet1, Sheet1.Range("B8:C8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("B9:B18"), "id")
Call SetFormat(Sheet1, Sheet1.Range("C9:C18"), "val")
Call SetFormat(Sheet1, Sheet1.Range("E8:E8"), "id")
Call SetFormat(Sheet1, Sheet1.Range("E9:E9"), "val")
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
End Sub
' 最大値を抽出し強調表示する
Sub MakeMaxValueTable()
' =====================
' 開始処理
' =====================
' 結果表示時のちらつきが気持ち悪いので、非表示
Application.ScreenUpdating = False
'画面初期化
' 条件付き書式をクリア
Dim ws As Worksheet
For Each ws In Worksheets
ws.Cells.FormatConditions.Delete
Next ws
' グラフをクリア
With Sheet1
' 実行結果出力範囲をクリア
.Rows("2:3").Clear
Dim r As Long
For r = .ChartObjects.Count To 1 Step -1
.ChartObjects(r).Delete
Next r
End With
' =====================
' 入力チェック
' =====================
'リストの値を取得して、配列に格納
Dim arr_ori As Variant: arr_ori = Sheet1.Range("B9:C18").Value
' 閾値を取得
Dim line_val As Long: line_val = Sheet1.Range("E9").Value
' 最大値を取得
Dim max_val As Long: max_val = Application.WorksheetFunction.Max(arr_ori)
' 最大値 <= 閾値は処理終了
If (max_val <= line_val) Then
Dim rc As Integer
rc = MsgBox("閾値は最大値より小さい値を設定してください。" & vbCrLf & "最大値：" & max_val, vbOKOnly + vbExclamation)
If rc = vbOK Then
Exit Sub
End If
End If
' =====================
' コネクションOPEN
' =====================
' 処理対象ファイルのフルパス
Dim fileFullName As String
fileFullName = ThisWorkbook.FullName
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.PROVIDER = "MSDASQL"
cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; " & "DBQ=" & fileFullName & "; ReadOnly=False;"
cn.Open
' =====================
' SQL実行→結果取得
' =====================
Dim rs As ADODB.Recordset:
Set rs = New ADODB.Recordset
Dim sqlStr As String
' シート名のパラメータ化が必要
sqlStr = ""
sqlStr = sqlStr & " select"
sqlStr = sqlStr & " *"
sqlStr = sqlStr & " from"
sqlStr = sqlStr & " [Sheet1$]"
sqlStr = sqlStr & " where"
sqlStr = sqlStr & " Value > " & line_val
' adOpenStatic・・・よくわからないが、静的カーソル（他ユーザーによる追加・更新・削除は反映されない）と説明があり、テーブルロックしている？ってこと？
rs.Open sqlStr, cn, adOpenStatic
' =====================
' SQL実行結果出力
' =====================
' 抽出結果を出力・・・縦
' Sheet1.Range("G2").CopyFromRecordset rs
' 抽出結果を出力・・・横
Dim fieldCnt As Integer: fieldCnt = rs.Fields.Count
Dim recordCnt As Long: recordCnt = rs.RecordCount
' これで、横に格納してるみたいです
'ReDim recordArray(fieldCnt, recordCnt) As Variant: recordArray = rs.GetRows
'シートに出力
' 横に出力する場合は、起点のセルだけ指定だとうまくいかないみたいなので、出力するRangeを指定する。
'Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = recordArray
' 抽出結果で特に何もしないなら、直接設定する方が良い
Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1)) = rs.GetRows
' =====================
' コネクションCLOSE
' =====================
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
' 配列バージョン
' Dim i As Long
'
' Dim arrayCount As Long: arrayCount = UBound(arr_ori, 1)
' ReDim arr_ans(LBound(arr_ori, 2) To UBound(arr_ori, 2), 1 To UBound(arr_ori, 1))
'
' ' 閾値以上の値を抽出して、配列に再格納（行と列を入れ替えて格納する）
' ' j = 1で、IDを処理：IDに紐づく値が、閾値より大きい場合、IDを格納
' ' j = 2で、値を処理：閾値より大きい場合、値を格納
' For j = LBound(arr_ori, 2) To UBound(arr_ori, 2)
'
' Dim c As Long: c = 1
' For i = LBound(arr_ori, 1) To UBound(arr_ori, 1)
'
' If arr_ori(i, 2) > line_val Then
'
' arr_ans(j, c) = arr_ori(i, j)
' c = c + 1
' End If
'
' Next i
' Next j
'
' ' 閾値より大きい値の個数を、最大列数としてRangeに設定
' Dim clm As Long: clm = c
'
' '再格納した配列をエクセルに出力
' Sheet1.Range(Cells(2, 2), Cells(3, clm)).Value = arr_ans
' =====================
' 最大値の設定
' =====================
Dim fc As FormatCondition
' range・・・入れ子だと見辛いので、変数に格納
Dim resultDataRange As Range: Set resultDataRange = Sheet1.Range(Cells(3, 2), Cells(fieldCnt, recordCnt + 1))
' 条件付き書式を生成・・・入れ子だと見辛いので、変数に格納（.Addressの絶対参照を忘れないこと）
' MAX関数は、最大値が複数ある場合は、存在するだけ最大値と判定します
Dim strFormula As String: strFormula = "=B3=MAX(" & resultDataRange.Address & ")"
Set fc = resultDataRange.FormatConditions.Add( _
Type:=xlExpression, _
Formula1:=strFormula)
' 最大値の見た目を設定
fc.Interior.Color = RGB(255, 0, 0)
fc.Font.Color = RGB(255, 255, 255)
fc.Font.Bold = True
' =====================
' グラフを生成
' =====================
' 配列に入れなおさないとうまくいかないので、入れなおす。（この辺は、要検証）
Dim arr_ans() As Variant: arr_ans = Sheet1.Range(Cells(2, 2), Cells(fieldCnt, recordCnt + 1))
' グラフ生成用に、ヘッダーと値の配列を作成
Dim arr_ans_id As Variant: arr_ans_id = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 1, 0))
Dim arr_ans_val As Variant: arr_ans_val = WorksheetFunction.Transpose(WorksheetFunction.Index(arr_ans, 2, 0))
Call MakeChart(Sheet1, arr_ans_id, arr_ans_val, line_val)
' =====================
' 全体的な見た目の設定
' =====================
Call SetFormat(Sheet1, Sheet1.Range(Cells(2, 2), Cells(2, recordCnt + 1)), "id")
Call SetFormat(Sheet1, Sheet1.Range(Cells(3, 2), Cells(3, recordCnt + 1)), "val")
' =====================
' 終了処理
' =====================
' フォーカスを所定の位置へ
Sheet1.Range("A1").Select
Application.ScreenUpdating = True
End Sub
' 書式を設定
' 項目：id 、値:val
Sub SetFormat(ByVal sh As Worksheet, ByVal rng As Range, ByVal item As String)
sh.Select
rng.Select
With Selection
' 外枠の設定・・・ちなみにこれは、中太
'.BorderAround Weight:=xlMedium
.Borders.LineStyle = True
Select Case item
Case "id"
.HorizontalAlignment = xlCenter
.Interior.Color = rgbTurquoise
Case "val"
.NumberFormatLocal = "#,###"
End Select
End With
End Sub
' グラフを生成
Sub MakeChart(ByVal sh As Worksheet, ByVal arr_header As Variant, ByVal arr_val As Variant, ByVal line_val As Long)
sh.Select
Dim co As ChartObject
' グラフの外枠？を設置
Set co = ActiveSheet.ChartObjects.Add(Left:=Range("G8").Left, Top:=Range("G8").Top, Width:=324, Height:=206)
' グラフの中身を生成
With co
With .Chart.SeriesCollection.NewSeries
.Name = "Value"
.Values = arr_val
.XValues = arr_header
End With
End With
With co.Chart
'グラフ形式を設定
co.Chart.ChartType = xlColumnClustered
'凡例非表示
co.Chart.HasLegend = True
' グラフの左線を強調（線の太さと色・・・結構見やすいかも）
.Axes(xlValue).Format.Line.Weight = 2
.Axes(xlValue).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
' グラフの下線を強調
.Axes(xlCategory).Format.Line.Weight = 2
.Axes(xlCategory).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
'基準線を新規系列として追加
With .SeriesCollection.NewSeries
.Name = "=""閾値""" '特に必要はない
.Values = "={" & Join(Array(line_val, line_val), ",") & "}"
.ChartType = xlLine '折れ線
.AxisGroup = 2 '第2軸
.Format.Line.ForeColor.RGB = vbRed 'RGB(255, 0, 0)
End With
'第2縦軸のScaleを第1縦軸に合わせる
.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
.Axes(xlValue, 2).Delete '第2軸を消す
'グラフ内左右余白を消す：基準線を第2横軸に設定
.HasAxis(xlCategory, 2) = True '第2横軸表示
.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
End With
End Sub
vba：EXCELSQL
内容
- シートのテーブル(テーブル化は不要みたい)に対して、SQLで処理を行う。
' Excelシートのデータに対して、SQLで対象を取得する
Sub ExeSql()
' 処理対象ファイルのフルパス
Dim fileFullName As String
fileFullName = ThisWorkbook.FullName
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.PROVIDER = "MSDASQL"
cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; " & "DBQ=" & fileFullName & "; ReadOnly=False;"
cn.Open
Dim rs As ADODB.recordset
Set rs = New ADODB.recordset
Dim lineLimit As String: lineLimit = 4000
Dim sqlStr As String
sqlStr = ""
' シンプルSQL
sqlStr = sqlStr & " select"
sqlStr = sqlStr & " *"
sqlStr = sqlStr & " from"
sqlStr = sqlStr & " [Sheet1$]"
sqlStr = sqlStr & " where"
sqlStr = sqlStr & " LINE_LIMIT > " & lineLimit
' joinしてみる
' sqlStr = sqlStr & " select a.* from [Sheet1$] a left join [Sheet5$] b on a.ITEM_CD = b.ITEM_CD"
' sqlStr = sqlStr & " where b.LINE_NO = 2"
' case(IIF)してみる・・・IIFを使ったときは、どうやらカラムを個別で指定する必要がある。・・・*とかを使った場合は、先頭にIIFの検索結果が出力されるみたいです
' sqlStr = sqlStr & " select LINE_CD, LINE_LIMIT, ITEM_CD, IIF(LINE_LIMIT = 500,1,IIF(LINE_LIMIT = 1000,2,3)) as ll from [Sheet1$] "
Debug.Print sqlStr
' adOpenStatic・・・よくわからないが、静的カーソル（他ユーザーによる追加・更新・削除は反映されない）と説明があり、テーブルロックしている？ってこと？
rs.Open sqlStr, cn, adOpenStatic
' 抽出結果を出力・・・縦
' Sheet1.Range("G2").CopyFromRecordset rs
' 抽出結果を出力・・・横
Dim fieldCnt As Integer: fieldCnt = rs.Fields.Count
Dim recordCnt As Long: recordCnt = rs.RecordCount
' これで、横に格納してるみたいです
ReDim recordArray(fieldCnt, recordCnt) As Variant: recordArray = rs.GetRows
'シートに出力
' 横に出力する場合は、起点のセルだけ指定だとうまくいかないみたいなので、出力するRangeを指定する。
Sheet1.Range(Cells(1, 7), Cells(fieldCnt, recordCnt + 6)) = recordArray
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub
vba：ListObjects（今思っていること）
基本的な考え方
ListObjectsについて（本題）
- ListObjectsをできる限り利用するようにしたいと考えている。
- 理由としては、最終行などの取得などの処理がないこと。
- 多分、関数を使う時よりも、速い気がする。
- どちらかというと、多少の処理速度よりもソースの見やすさや改修のしやすさを重視したいので、たぶん、ListObjectsの方がシンプルなソースになると思う。
Sub CalcKyakutanka()
If Sheet1.ListObjects.Count > 0 Then
Sheet1.ListObjects(1).Unlist
End If
'Sheet1.Cells.Clear
Stop
With Sheet1
.Range("A1").Select
With .ListObjects.Add
' テーブル名・・・省略可能
' .Name = "tbl_Kyakutanka"
' 行からセルを特定・・・2行目の4列目
' .ListRows(1).Range.Item(4).Formula = "=[@売上]/[@客数]"
' 列からセルを特定・・・4列目の2行目
' .ListColumns(4).Range(2).Formula = "=INT([@売上]/[@客数])" '・・・整数
.ListColumns(4).Range(2).Formula = "=ROUND([@売上]/[@客数],2)" '・・・小数点第2で、丸目
' 列（列名）から、セルを特定・・・客単価列の2行目
' .ListColumns("客単価").Range(2).Formula = "=[@売上]/[@客数]"
' 小数点を設定・・・注意：四捨五入で繰り上げされます
'.ListColumns(4).Range.NumberFormatLocal = "##.##"
Dim arr_ans_uriage As Variant: arr_ans_uriage = .ListColumns(2).DataBodyRange
Dim arr_ans_kyakusu As Variant: arr_ans_kyakusu = .ListColumns(3).DataBodyRange
Dim arr_ans_kyakutanka As Variant: arr_ans_kyakutanka = .ListColumns(4).DataBodyRange
End With
End With
With Sheet1.ListObjects(1)
Call MakeChart(Sheet1, arr_ans_uriage, 34500, .ListColumns(2).Range(1).Value, Range("F2"), Range("K2"))
Call MakeChart(Sheet1, arr_ans_kyakusu, 50, .ListColumns(3).Range(1).Value, Range("F14"), Range("K14"))
Call MakeChart(Sheet1, arr_ans_kyakutanka, 1000, .ListColumns(4).Range(1).Value, Range("F26"), Range("K26"))
' Call MakeChart(Sheet1, arr_ans_kyakutanka, arr_ans_uriage, 50, .ListColumns(4).Range(1).Value, Range("F2"), Range("K2"))
End With
End Sub
' グラフを生成
'Sub MakeChart(ByVal sh As Worksheet, ByVal arr_header As Variant, ByVal arr_val As Variant, ByVal line_val As Long)
Sub MakeChart(ByVal sh As Worksheet, ByVal arr_val As Variant, ByVal line_val As Long, ByVal chartNames As String, ByVal lRng As Range, ByVal tRnge As Range)
'Sub MakeChart(ByVal sh As Worksheet, ByVal arr_val As Variant, ByVal arr_val_line As Variant, ByVal line_val As Long, ByVal chartNames As String, ByVal lRng As Range, ByVal tRnge As Range)
sh.Select
Dim co As ChartObject
' グラフの外枠？を設置
Set co = ActiveSheet.ChartObjects.Add(Left:=lRng.Left, Top:=tRnge.Top, Width:=300, Height:=200)
' グラフの中身を生成
With co
With .Chart.SeriesCollection.NewSeries
.Name = chartNames
.Values = arr_val
'.XValues = arr_header
End With
End With
With co.Chart
' グラフのスタイルを設定
.ChartStyle = 209
'グラフ形式を設定
co.Chart.ChartType = xlColumnClustered
'凡例非表示
co.Chart.HasLegend = True
' ' グラフの左線を強調（線の太さと色・・・結構見やすいかも）
' .Axes(xlValue).Format.Line.Weight = 2
' .Axes(xlValue).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
'
' ' グラフの下線を強調
' .Axes(xlCategory).Format.Line.Weight = 2
' .Axes(xlCategory).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
' '折れ線グラフを追加
' With .SeriesCollection.NewSeries
' .Name = "客数"
' .Values = arr_val_line
' .ChartType = xlLineMarkers '折れ線
' .AxisGroup = 2 '第2軸
' .Format.Line.ForeColor.RGB = RGB(255, 192, 0)
' End With
'基準線を新規系列として追加
With .SeriesCollection.NewSeries
.Name = "閾値" '特に必要はない
.Values = "={" & Join(Array(line_val, line_val), ",") & "}"
.ChartType = xlLine '折れ線
.AxisGroup = 2 '第2軸
.Format.Line.ForeColor.RGB = RGB(255, 192, 0)
End With
'第2縦軸のScaleを第1縦軸に合わせる
.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
.Axes(xlValue, 2).Delete '第2軸を消す
'グラフ内左右余白を消す：基準線を第2横軸に設定
.HasAxis(xlCategory, 2) = True '第2横軸表示
.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
End With
End Sub
