エクセルに関する雑多な纏め
【VBA入門】ファイルOpenに何秒かかるか。処理速度を計測し実測を評価する https://www.cellnets.co.jp/dev_column/9160 【5分でVBA学習】マクロ処理高速化 ～Excelフィルタリングツール コード解説 #1～ https://qiita.com/TakuyaSuzuki/items/158ec6815509fd27de67
演出制御式 凍結With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .Cursor = xlWait End With解凍With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .Cursor = xlDefault End With※ Calculation オプションはめんどくさいので注意
VBA【最速】開かずに別ブックから【値を取得】セルの転記【自由度MAX】 https://jovba.com/2022/12/29/other_books1/
演出 凍結・解凍式Sub Focus(ByVal Flag As Boolean) With Application .EnableEvents = Not Flag .ScreenUpdating = Not Flag .Calculation = IIf(Flag, xlCalculationManual, xlCalculationAutomatic) End With End Sub
テーマの移植に関するサブルーチンSub CopyTheme(ByVal sourceBook As Workbook, ByVal targetBook As Workbook) Dim themePath As String 'ブックのテーマをテンポラリファイルとしてエクスポート themePath = Environ("TEMP") & "\temp_theme.thmx" sourceBook.SaveAs Filename:=themePath, FileFormat:=52 ' 52 = xlOpenXMLTheme 'ブックにテーマをインポート targetBook.ApplyTheme themePath 'テンポラリファイルを削除 Kill themePath End Subしかし、これは不完全
VBAでログをシートに記述するためのクラスを作りたい VBAでログをシートに書き込むためのクラスを作成するには、以下のような手順で作成できます。この例では、「Logger」というクラスを作成し、ログをExcelの指定したシートに書き込むためのメソッドを実装します。 1. Logger クラスモジュールの作成 VBAエディタで「挿入」 > 「クラスモジュール」を選び、クラス名を「Logger」に変更してください。 2. Logger クラスのコード 以下のコードをLoggerクラスに貼り付けてください。' Logger クラス Option Explicit Private logSheet As Worksheet Private currentRow As Long ' 初期化：ログシートと初期行を設定 Public Sub Init(sheetName As String) On Error Resume Next Set logSheet = ThisWorkbook.Sheets(sheetName) If logSheet Is Nothing Then ' シートが存在しない場合、新規作成 Set logSheet = ThisWorkbook.Sheets.Add logSheet.Name = sheetName End If On Error GoTo 0 ' 初期行の設定（1行目にヘッダーを設定） currentRow = logSheet.Cells(logSheet.Rows.Count, 1).End(xlUp).Row + 1 If currentRow = 1 Then logSheet.Cells(currentRow, 1).Value = "Date" logSheet.Cells(currentRow, 2).Value = "Time" logSheet.Cells(currentRow, 3).Value = "Log Message" currentRow = currentRow + 1 End If End Sub ' ログメッセージの追加 Public Sub WriteLog(message As String) If logSheet Is Nothing Then MsgBox "ログシートが初期化されていません。Init メソッドを呼び出してください。", vbExclamation Exit Sub End If logSheet.Cells(currentRow, 1).Value = Date logSheet.Cells(currentRow, 2).Value = Time logSheet.Cells(currentRow, 3).Value = message currentRow = currentRow + 1 End Sub3. Logger クラスの使用例 標準モジュールに以下のようなコードを書いて、Loggerクラスを使ってログを書き込むことができます。Sub TestLogger() Dim logger As New Logger logger.Init "LogSheet" ' "LogSheet" という名前のシートにログを記述 ' サンプルメッセージのログ出力 logger.WriteLog "アプリケーションが開始されました。" logger.WriteLog "ユーザーがデータを更新しました。" logger.WriteLog "アプリケーションが終了されました。" End Subコードの説明
- Init
- WriteLog
- TestLoggerサブを実行すると、"LogSheet"シートにログが記録されます。
- 以後、WriteLogを呼び出すことで、任意のメッセージをログに追加できます。
Public logger As Logger
これで、logger変数はプロジェクト全体で使用できるようになります。
2. 初期化処理の追加
グローバル変数を使用する前に、loggerオブジェクトを初期化する必要があります。これを実行するための初期化用サブプロシージャを追加しておくと便利です。
Sub InitializeLogger()
If logger Is Nothing Then
Set logger = New Logger
logger.Init "LogSheet" ' ログシートを初期化
End If
End Sub
InitializeLogger サブを呼び出すことで、logger が適切に初期化されます。
3. グローバル変数 logger の利用
グローバル変数に設定されたloggerを、他のプロシージャから直接使用できます。使用する前に InitializeLogger を呼び出して初期化するようにしてください。
Sub TestLog()
' ロガーを初期化
InitializeLogger
' グローバル変数loggerを使用してログを記録
logger.WriteLog "グローバルログ: アクションが実行されました。"
End Sub
注意点
- loggerが Nothing のままの場合を避けるため、InitializeLoggerを必ず実行してから使用するようにしてください。
- Application.Openイベントなどに初期化処理を入れると、ブックを開いた際に自動で初期化できます。
VBAで日本語テキストの文字コード判定 https://qiita.com/ddxb-0x41/items/7a36cf9b01945bf3fe63
警告コメントを付与したいよね。Sub test() Dim str1 As String, str2 As String, strM As String str1 = "レコードのパスが重複しています. 重複コード'Dp-2'を持つレコードが１つ以下になるように調整してください." str2 = "レコードの番号が重複しています. 重複コード'Dn-3'を持つレコードが一意の番号を持つように調整してください." strM = str1 & vbCrLf & str2 & vbCrLf & "(番号欄をダブルクリックすることで番号の削除・再割り当てを行えます.)" Call setWarningComment(ThisWorkbook.Sheets("Sheet1").Range("C4:F9"), strM) End Sub '警告コメントを付与する関数 (vbCrLfで改行) Sub setWarningComment(area As Range, comment As String) Dim oneCell As Range, nearCell As Range Set oneCell = area.Cells.Item(1, 1) Set nearCell = oneCell.Offset(0, -1) oneCell.ClearComments oneCell.AddComment comment oneCell.comment.Shape.Top = nearCell.Top oneCell.comment.Shape.Left = nearCell.Left oneCell.comment.Shape.TextFrame.AutoSize = True oneCell.comment.Shape.TextFrame.Characters.Font.Size = 12 oneCell.comment.Shape.Fill.ForeColor.RGB = RGB(255, 220, 180) End Sub
おまけ'数値の桁数を0の数で返す関数 Function lenStrLen(str As Long) As String lenStrLen = String(Len(CStr(str)), "0") End Function
独自定義関数を利用して括弧内だけ抜き出すFunction ExtractionStrings(rngValue) Dim startNum As Integer, endNum As Integer startNum = InStr(rngValue, "(") endNum = InStr(startNum + 1, rngValue, ")") If startNum <> 0 And endNum <> 0 Then startNum = startNum + 1 ExtractionStrings = Mid(rngValue, startNum, endNum - startNum) Else ExtractionStrings = "" End If End Function
都合の良い二次元配列が欲しいだろ？Sub Create2DArray(ByVal columns As Variant, ByVal startWidth As Long) Dim ws As Worksheet Dim maxRow As Long Dim dataRange As Range Dim newArray() As Variant Dim i As Long, j As Long Dim rowCount As Long ' アクティブシートを設定 Set ws = ActiveSheet ' 最大行数を取得（シートのデータ範囲に基づく） maxRow = ws.Cells(ws.Rows.Count, columns(0)).End(xlUp).Row ' 最初の列の最終行 ' 行数の決定（2行目から最大行数まで） rowCount = maxRow - 1 ' 配列のサイズを指定して新規作成 ReDim newArray(1 To rowCount, 1 To UBound(columns) + 1) ' 指定された列からデータを新しい配列にコピー For i = 1 To rowCount For j = 1 To UBound(columns) + 1 ' 各列番号を参照してデータを取得 newArray(i, j) = ws.Cells(i + 1, columns(j - 1)).Value ' i+1で2行目から取得 Next j Next i ' 新しい配列の内容をデバッグ出力で確認 For i = 1 To rowCount For j = 1 To UBound(columns) + 1 Debug.Print "newArray(" & i & ", " & j & ") = " & newArray(i, j) Next j Next i End Sub
都合の良い。Ｓｕｍｍａｒｙ生成系がほしいOption Explicit '変数宣言強制 Sub writeSummaryTable(ByRef dictStructure As Object, ByRef writeSheet As Worksheet, ByRef rowStart As Long, ByRef columnStart As Long, Optional ByVal titleArray As Variant = Empty) Dim numberOfField As Long, buffer As Long, i As Long, ii As Long Dim pointOfStart As Range, targetCell As Range, targetArea As Range Dim sourceOfCount As Long Dim mergeCellCounter As Object, sortedIndexOfDictStructure As Variant Dim mergeCellTempName As Object Dim arrayBuffer() As String, keyText As Variant Dim realValueFlag As Boolean Dim maxValue As Long '諸定数値セット Set pointOfStart = writeSheet.Cells.Item(rowStart, columnStart) Set mergeCellCounter = CreateObject("Scripting.Dictionary") Set mergeCellTempName = CreateObject("Scripting.Dictionary") sortedIndexOfDictStructure = dictStructure.keys 'キーを配列として取得 If IsEmpty(titleArray) = True Then titleArray = Array() End If '区切り文字の数を計算するブロック numberOfField = 1 For Each keyText In dictStructure buffer = UBound(Split(keyText, Chr(31))) + 1 If buffer > numberOfField Then numberOfField = buffer End If Next keyText 'セルのマージを担当するカウンター辞書 For i = 1 To numberOfField mergeCellCounter.Add i, 0 mergeCellTempName.Add i, vbNullString Next i '書式設定 pointOfStart.Offset(1, 0).Resize(dictStructure.Count, numberOfField - 1).NumberFormat = "@" '文字列指定 pointOfStart.Offset(1, numberOfField).Resize(dictStructure.Count, numberOfField).NumberFormat = "0" '数値指定 '記述 For i = dictStructure.Count To 1 Step -1 ReDim arrayBuffer(0 To numberOfField - 1) '不足している場合があるので拡張 arrayBuffer = Split(sortedIndexOfDictStructure(i - 1), Chr(31)) realValueFlag = True For ii = numberOfField To 1 Step -1 '値の書き込み pointOfStart.Offset(i, ii - 1).Value = CStr(arrayBuffer(ii - 1)) '値の書き込み If realValueFlag Then pointOfStart.Offset(i, numberOfField * 2 - ii).Value = dictStructure(sortedIndexOfDictStructure(i - 1)) realValueFlag = False Else pointOfStart.Offset(i, numberOfField * 2 - ii).Formula = "=SUM(" & pointOfStart.Offset(i, numberOfField * 2 - numberOfField).Resize(mergeCellCounter(ii) + 1, 1).Address & ")" End If 'MERGE処理 If CStr(arrayBuffer(ii - 1)) = mergeCellTempName(ii) And mergeCellCounter(ii) > 0 And numberOfField > ii Then pointOfStart.Offset(i, ii - 1).Resize(mergeCellCounter(ii) + 1, 1).Merge pointOfStart.Offset(i, numberOfField * 2 - ii).Resize(mergeCellCounter(ii) + 1, 1).Merge mergeCellCounter(ii) = mergeCellCounter(ii) + 1 Else mergeCellCounter(ii) = 1 End If mergeCellTempName(ii) = CStr(arrayBuffer(ii - 1)) Next ii Next i '合計値計算 pointOfStart.Offset(1, numberOfField * 2).Formula = "=SUM(" & pointOfStart.Offset(1, numberOfField).Resize(dictStructure.Count, 1).Address & ")" With pointOfStart.Offset(1, numberOfField * 2).Resize(dictStructure.Count, 1) .Merge .Interior.Color = RGB(250, 250, 250) End With '表の形成 With pointOfStart.Offset(0, 0).Resize(dictStructure.Count + 1, numberOfField * 2).Borders .LineStyle = xlContinuous .Weight = xlThin .Color = RGB(0, 0, 0) End With Call setBorderAroundRange(pointOfStart.Offset(1, 0).Resize(dictStructure.Count, numberOfField * 2), xlMedium, xlThick, xlThick, xlMedium) Call setBorderAroundRange(pointOfStart.Offset(1, numberOfField * 2).Resize(dictStructure.Count, 1), xlThick, xlThick, xlMedium, xlThick) 'タイトルの設定 With pointOfStart.Resize(1, numberOfField * 2) .Interior.Color = RGB(220, 220, 220) .Font.Bold = True End With Call setBorderAroundRange(pointOfStart.Resize(1, numberOfField * 2), xlThick, xlMedium, xlThick, xlThick) For i = 0 To numberOfField - 1 If LBound(titleArray) <= i And i <= UBound(titleArray) Then pointOfStart.Offset(0, i).Value = CStr(titleArray(i)) pointOfStart.Offset(0, i + numberOfField).Value = CStr(titleArray(i)) & " 件数" Else pointOfStart.Offset(0, i).Value = "" pointOfStart.Offset(0, i + numberOfField).Value = "" End If Next i Set targetArea = pointOfStart.Offset(1, 0).Resize(dictStructure.Count, numberOfField * 2) 'セルエラー無効化 For Each targetCell In targetArea If targetCell.Errors.Item(xlNumberAsText).Ignore = False Then targetCell.Errors.Item(xlNumberAsText).Ignore = True End If Next 'シート再計算 writeSheet.Calculate '条件付き書式を付与 pointOfStart.Offset(1, 0).Resize(dictStructure.Count, numberOfField).FormatConditions.Delete '条件付き書式を抹消 For i = numberOfField To numberOfField * 2 - 1 '条件付き書式を追加（白から赤へのグラデーション） '最大値取得ブロック maxValue = 0 Set targetArea = pointOfStart.Offset(1, i).Resize(dictStructure.Count, 1) '再定義 For Each targetCell In targetArea If IsNumeric(targetCell.Value) And Not IsEmpty(targetCell.Value) Then If targetCell.Value > maxValue Then maxValue = targetCell.Value End If End If Next targetCell '付与ブロック１ With targetArea.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0") .Interior.Color = RGB(255, 255, 255) ' 白色 End With '付与ブロック２ With targetArea.FormatConditions.AddColorScale(ColorScaleType:=2) '最小値の色（白: RGB(255,255,255)） .ColorScaleCriteria(1).Type = xlConditionValueLowestValue .ColorScaleCriteria(1).FormatColor.Color = RGB(255, 255, 255) '最大値の色（赤: RGB(255,0,0)） .ColorScaleCriteria(2).Type = xlConditionValueHighestValue .ColorScaleCriteria(2).FormatColor.Color = RGB(255, 0, 0) End With Next i End Sub 'セル範囲の周りを太めの線で囲むサブルーチン Sub setBorderAroundRange(ByRef area As Range, Optional ByVal topWeight = xlThick, Optional ByVal bottomWeight = xlThick, Optional ByVal leftWeight = xlThick, Optional ByVal rightWeight = xlThick) With area.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = topWeight .Color = RGB(0, 0, 0) End With With area.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = bottomWeight .Color = RGB(0, 0, 0) End With With area.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = leftWeight .Color = RGB(0, 0, 0) End With With area.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = rightWeight .Color = RGB(0, 0, 0) End With End Sub '表の幅を調整するためのサブルーチン Sub adjustRange(ByRef targetArea As Range, Optional ByVal minHeight As Long = 18, Optional ByVal minWidth As Long = 8.5) Dim ca As Range, ra As Range, cell As Range Dim aliveColDict As Object, aliveRowDict As Object Set aliveColDict = CreateObject("Scripting.Dictionary") Set aliveRowDict = CreateObject("Scripting.Dictionary") targetArea.WrapText = False '折り返しを無効にする targetArea.EntireColumn.AutoFit '文字列の長さに合わせて自動調整 targetArea.EntireRow.AutoFit '文字列の長さに合わせて自動調整 '最低幅を設定 For Each cell In targetArea If aliveRowDict.exists(cell.Top) = False Then aliveRowDict.Add cell.Top, False End If If aliveColDict.exists(cell.Left) = False Then aliveColDict.Add cell.Left, False End If If IsEmpty(cell) = False Then If aliveRowDict(cell.Top) = False Then aliveRowDict(cell.Top) = True End If If aliveColDict(cell.Left) = False Then aliveColDict(cell.Left) = True End If End If Next cell For Each ca In targetArea.Columns If ca.ColumnWidth < minWidth Then ca.ColumnWidth = minWidth End If Next ca For Each ra In targetArea.Rows If ra.RowHeight < minHeight Then ra.RowHeight = minHeight End If Next ra End Sub '棒グラフを生成するサブルーチン Sub CreateBarChart(ByRef chartRange As Range, ByRef chartSheet As Worksheet, Optional ByVal chartTop As Long = 1, Optional ByVal chartLeft As Long = 1, Optional ByVal sizeHeight As Long = 10, Optional ByVal sizeWidth As Long = 12) Dim ws As Worksheet Dim chartOfBar As chartObject Dim chartTopLeft As Range Dim series As series Dim i As Long 'グラフを挿入する左上の起点セルを設定 Set chartTopLeft = chartSheet.Cells.Item(chartTop, chartLeft) Debug.Print chartTopLeft.Width & " * " & sizeWidth & " = " & chartTopLeft.Width * sizeWidth 'グラフを追加 Set chartOfBar = chartSheet.ChartObjects.Add(Left:=chartTopLeft.Left, Top:=chartTopLeft.Top, Width:=chartTopLeft.Width * sizeWidth, Height:=chartTopLeft.Height * sizeHeight) ' グラフの種類を設定（縦棒グラフ） With chartOfBar.Chart .SetSourceData Source:=chartRange .ChartType = xlColumnClustered ' クラスター縦棒グラフ .HasTitle = True .ChartTitle.Text = "" .Axes(xlCategory).HasTitle = True .Axes(xlCategory).AxisTitle.Text = "カテゴリ" .Axes(xlValue).HasTitle = True .Axes(xlValue).AxisTitle.Text = "件数" .HasLegend = False For i = 1 To .SeriesCollection.Count 'どちらにしろ1つだけではあるが、一応定義 Set series = .SeriesCollection(i) series.Format.Fill.ForeColor.RGB = RGB(255, 0, 0) '赤 ' データ系列に数値ラベルを追加 With .SeriesCollection(i) .HasDataLabels = True .DataLabels.NumberFormat = "0" '数値のフォーマットを設定（整数） End With Next i End With End Sub '全てのグラフを抹消するサブルーチン Sub deleteAllCharts(chartSheet As Worksheet) Dim chartObj As chartObject 'ワークシート内のすべてのグラフオブジェクトを削除 For Each chartObj In chartSheet.ChartObjects chartObj.Delete Next chartObj End Sub Sub test() Dim dictS As Object, titleArray As Variant Application.DisplayAlerts = False Call deleteAllCharts(ThisWorkbook.Sheets("Sheet1")) Set dictS = CreateObject("Scripting.Dictionary") dictS.Add "AAA" & Chr(31) & "001" & Chr(31) & "a", 0 dictS.Add "AAA" & Chr(31) & "001" & Chr(31) & "b", 2 dictS.Add "AAA" & Chr(31) & "002" & Chr(31) & "a", 3 dictS.Add "AAA" & Chr(31) & "002" & Chr(31) & "b", 0 dictS.Add "AAA" & Chr(31) & "003" & Chr(31) & "a", 3 dictS.Add "AAA" & Chr(31) & "003" & Chr(31) & "b", 0 dictS.Add "BBB" & Chr(31) & "001" & Chr(31) & "a", 2 dictS.Add "BBB" & Chr(31) & "001" & Chr(31) & "b", 0 dictS.Add "BBB" & Chr(31) & "002" & Chr(31) & "a", 0 dictS.Add "BBB" & Chr(31) & "002" & Chr(31) & "b", 1 dictS.Add "BBB" & Chr(31) & "003" & Chr(31) & "a", 0 dictS.Add "BBB" & Chr(31) & "003" & Chr(31) & "b", 1 dictS.Add "CCC" & Chr(31) & "001" & Chr(31) & "a", 1 dictS.Add "CCC" & Chr(31) & "001" & Chr(31) & "b", 1 dictS.Add "CCC" & Chr(31) & "002" & Chr(31) & "a", 0 dictS.Add "CCC" & Chr(31) & "002" & Chr(31) & "b", 0 dictS.Add "CCC" & Chr(31) & "003" & Chr(31) & "a", 1 dictS.Add "CCC" & Chr(31) & "003" & Chr(31) & "b", 0 With ThisWorkbook.Sheets("Sheet1").Cells.Item(1, 1).Resize(90, 90) .UnMerge .Clear End With titleArray = Array("基幹", "分散", "個別") Call writeSummaryTable(dictS, ThisWorkbook.Sheets("Sheet1"), 2, 2, titleArray) Call adjustRange(ThisWorkbook.Sheets("Sheet1").Cells.Item(1, 1).Resize(50, 50)) Call CreateBarChart(ThisWorkbook.Sheets("Sheet1").Range("B2:E20"), ThisWorkbook.Sheets("Sheet1"), 2, 10, 20, 12) Application.DisplayAlerts = True End Sub