QAT、リボンに配置する基本マクロ。QATやリボンに登録して使用すると便利
（Microsoft365 64bit環境推奨）
New Base Macro Book をコピーしてモジュールを追加して使用します
- 【Alt】＋【F11】キーを押下し、VBE画面を出す。
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【E01_Basic】に変更する。
モジュール名：E01_Basic
Option Explicit
'+++*********************************************************+++
' 列表示変更
'+++*********************************************************+++
Sub A_One_A()
'=== 前処理 ===
If IsCall = False Then Call StopUpdating
If Application.ReferenceStyle = xlR1C1 Then
Application.ReferenceStyle = xlA1
Else
Application.ReferenceStyle = xlR1C1
End If
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 全シートA1に画面スクロール
'+++*********************************************************+++
Sub exeAllA1()
Dim i As Long
'=== 前処理 ===
If IsCall = False Then Call StopUpdating
Call showStatus("セルA1 画面セット中")
If IsCall = False Then Call StopUpdating
With ActiveWorkbook
'一時的にエラー無視
On Error Resume Next
For i = .Sheets.Count To 1 Step -1
With .Worksheets(i)
If .Visible Then
.Select
Application.GoTo reference:=Range("A1"), _
Scroll:=True
End If
End With
Next i
'エラーハンドリング解除
On Error GoTo 0
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' マージ
' 選択セルを結合し､左寄せ､中央揃え､1文字インテンド
'+++*********************************************************+++
Sub Merge()
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
Selection.Merge
With Selection
'インテンドを初期化するため
.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.WrapText = True
'.ShrinkToFit = False
.MergeCells = True
'インテンドを1入れる
.InsertIndent 1
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 行ごとマージ
' 選択範囲を行ごとのセル結合し、列幅・行高を調整
' インテンド設定なし（WrapTextのみ）
'+++*********************************************************+++
Sub byRowMerge()
Dim i As Long
Dim j As Long
Dim MaxCol As Long ' シートの最終列番号
Dim dstCol As Long ' 作業列（結合幅確認用）
Dim sttRow As Long ' 選択範囲の開始行
Dim endRow As Long ' 選択範囲の終了行
Dim sttCol As Long ' 選択範囲の開始列
Dim endCol As Long ' 選択範囲の終了列
Dim rowCnt As Long ' 選択範囲の行数
Dim colCnt As Long ' 選択範囲の列数
Dim cWidth As Double ' 結合対象列の合計幅
Dim cOrgWidth As Double ' 作業列の元の幅
Dim myTune As Double ' 列幅調整用の微調整値
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
' 列幅の合計に微妙なズレが出るため、調整値を設定
myTune = 0.58
'=== 作業列の設定 ===
With ActiveSheet
MaxCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column
dstCol = MaxCol + 3 ' 作業列は最終列の3列右
End With
'=== 選択範囲の情報取得 ===
With Selection
.UnMerge ' 結合解除
sttRow = .item(1).Row
endRow = .item(.Count).Row
sttCol = .item(1).Column
endCol = .item(.Count).Column
rowCnt = endRow - sttRow + 1
colCnt = endCol - sttCol + 1
' 結合対象列の合計幅を計算
cWidth = 0
If endCol > MaxCol Then dstCol = endCol + 3
For j = sttCol To endCol
cWidth = cWidth + ActiveSheet.Columns(j).ColumnWidth + myTune
Next j
' 作業列の元の幅を保存し、合計幅に設定
cOrgWidth = ActiveSheet.Columns(dstCol).ColumnWidth
ActiveSheet.Columns(dstCol).ColumnWidth = cWidth
'=== 行ごとにセル結合・折り返し設定 ===
With ActiveSheet
For i = sttRow To endRow
.Range(.Cells(i, sttCol), .Cells(i, endCol)).Merge
.Range(.Cells(i, sttCol), .Cells(i, endCol)).WrapText = True
.Cells(i, dstCol).Value = 1 ' 作業列にマーク（後でコピー用）
Next i
End With
End With
'=== 作業列を使って行高調整・整形 ===
With ActiveSheet
' 結合セルの内容を作業列にコピー
.Cells(sttRow, sttCol).Resize(rowCnt).Copy .Cells(sttRow, dstCol)
.Cells(sttRow, dstCol).Resize(rowCnt).WrapText = True
' 行の高さを自動調整
.Cells(sttRow, dstCol).Resize(rowCnt).EntireRow.AutoFit
For i = sttRow To endRow
.Rows(i).RowHeight = .Rows(i).RowHeight ' 高さを確定
Next i
' 作業列をクリア
.Cells(sttRow, dstCol).Resize(rowCnt).Clear
.Columns(dstCol).ColumnWidth = cOrgWidth ' 列幅を元に戻す
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 選択範囲内の空白行の行高を2.5に変更
' 非空白行は標準の高さ（15）に設定
'+++*********************************************************+++
Sub chgLineHeight2()
Dim rng As Range ' 選択範囲
Dim myRow As Range ' 各行の範囲
Dim lastRow As Long ' 選択範囲の最終行番号（未使用）
Dim rowHtA As Double ' 非空白行の行高（標準）
Dim rowHtB As Double ' 空白行の行高（狭く）
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
rowHtA = 15 ' 標準行高（非空白行）
rowHtB = 2.5 ' 空白行の行高（狭く）
With ActiveSheet
'=== 選択範囲の取得 ===
Set rng = Application.Selection
'=== 各行をループして行高を調整 ===
For Each myRow In rng.Rows
If WorksheetFunction.CountA(myRow) = 0 Then
' 空白行 → 行高を狭く
myRow.RowHeight = rowHtB
Else
' 非空白行 → 標準の高さに戻す
myRow.RowHeight = rowHtA
End If
Next myRow
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 選択範囲内の空白行の行高を4.5に変更
' 非空白行は標準の高さ（15）に設定
'+++*********************************************************+++
Sub chgLineHeight4()
Dim rng As Range ' 選択範囲
Dim myRow As Range ' 各行の範囲
Dim lastRow As Long ' 選択範囲の最終行番号（未使用）
Dim rowHtA As Double ' 非空白行の行高（標準）
Dim rowHtB As Double ' 空白行の行高（狭く）
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
rowHtA = 15 ' 標準行高（非空白行）
rowHtB = 4.5 ' 空白行の行高（狭く）
With ActiveSheet
'=== 選択範囲の取得 ===
Set rng = Application.Selection
'=== 各行をループして行高を調整 ===
For Each myRow In rng.Rows
If WorksheetFunction.CountA(myRow) = 0 Then
' 空白行 → 行高を狭く
myRow.RowHeight = rowHtB
Else
' 非空白行 → 標準の高さに戻す
myRow.RowHeight = rowHtA
End If
Next myRow
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 選択範囲内の空白行の行高を１０に変更
' 非空白行は標準の高さ（15）に設定
'+++*********************************************************+++
Sub chgLineHeight10()
Dim rng As Range ' 選択範囲
Dim myRow As Range ' 各行の範囲
Dim lastRow As Long ' 選択範囲の最終行番号（未使用）
Dim rowHtA As Double ' 非空白行の行高（標準）
Dim rowHtB As Double ' 空白行の行高（狭く）
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
rowHtA = 15 ' 標準行高（非空白行）
rowHtB = 10 ' 空白行の行高（狭く）
With ActiveSheet
'=== 選択範囲の取得 ===
Set rng = Application.Selection
'=== 各行をループして行高を調整 ===
For Each myRow In rng.Rows
If WorksheetFunction.CountA(myRow) = 0 Then
' 空白行 → 行高を狭く
myRow.RowHeight = rowHtB
Else
' 非空白行 → 標準の高さに戻す
myRow.RowHeight = rowHtA
End If
Next myRow
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 選択範囲内で空白セルを含む行を静かに削除（SpecialCells使用）
'+++*********************************************************+++
Sub DelBlankRowsInSelection()
Dim rng As Range ' 選択範囲
Dim blankCells As Range ' 空白セルの集合
Dim targetRange As Range ' 対象範囲（選択範囲に限定）
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
Set targetRange = Application.Selection
'=== 選択範囲内の空白セルを取得 ===
On Error Resume Next
Set blankCells = targetRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
'=== 空白セルがあれば、その行を削除 ===
If Not blankCells Is Nothing Then
blankCells.EntireRow.Delete
End If
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'''+++*********************************************************+++
''' 選択範囲内で文字が入っていない行を削除
'''+++*********************************************************+++
''Sub DelEmptyTextRowsInSelection()
''
'' Dim rng As Range ' 選択範囲
'' Dim myRow As Range ' 各行の範囲
'' Dim cell As Range ' 各セル
'' Dim hasText As Boolean ' 文字あり判定
''
'' '=== 前処理：画面更新停止（外部プロシージャ） ===
'' If IsCall = False Then Call StopUpdating
''
'' Set rng = Application.Selection
''
'' '=== 後ろから順に行をチェックして削除 ===
'' With ActiveSheet
'' For Each myRow In rng.Rows
'' hasText = False
''
'' ' 行内のセルに文字があるかチェック（空白や数値は除外）
'' For Each cell In myRow.Cells
'' If Len(Trim(cell.Text)) > 0 Then
'' hasText = True
'' Exit For
'' End If
'' Next cell
''
'' ' 文字がなければ削除
'' If Not hasText Then
'' myRow.Delete
'' End If
'' Next myRow
'' End With
''
'' '=== 他ブックから呼び出された場合は最小化 ===
'' If ActiveWorkbook.Name <> ThisWorkbook.Name Then
'' Windows(ThisWorkbook.Name).WindowState = xlMinimized
'' End If
''
'' '=== 画面更新再開 ===
'' If IsCall = False Then Call Updating
''
''End Sub
'+++*********************************************************+++
' 結合セルの範囲を調査し、行数・列数・個数・位置を表示する
'+++*********************************************************+++
Sub InspectMergeArea()
Dim buf As String
With Range("A1").MergeArea
buf = ""
buf = buf & "行数: " & .Rows.Count & vbCrLf
buf = buf & "列数: " & .Columns.Count & vbCrLf
buf = buf & "セル数: " & .Count & vbCrLf
buf = buf & "左上: " & .item(1).Address(0, 0) & vbCrLf
buf = buf & "右下: " & .item(.Count).Address(0, 0)
End With
MsgBox buf, vbInformation, "結合セルの情報"
End Sub
'+++*********************************************************+++
' アクティブシートの全セルを前後トリム（軽量・最古参）
' ・ UsedRange の各セルに対して Trim を実行
' ・ 空白の余韻を静かに整える、原点の所作
'+++*********************************************************+++
Sub exeTrim()
Dim c As Range
Const PROsName = "exeTrim"
Application.StatusBar = "トリム中～"
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
With ActiveSheet
For Each c In .UsedRange
c.Value = Trim(c.Value)
Next c
End With
Application.StatusBar = ""
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' アクティブシートの全セルを整形（半角スペース統一・連続スペース除去）
' ・ 全角スペース → 半角スペース
' ・ 連続スペースを1つに統一
' ・ 前後トリム（2回）で余白の余韻まで整える
' ・ 配列処理で高速化、フィルター解除でズレ防止
' ・ 保存前処理で安心設計
'+++*********************************************************+++
Sub exeTrim_shtHfSpc()
Const PROsName = "exeTrim_shtHfSpc"
Dim dataArray As Variant ' 元データ配列
Dim i As Long, j As Long ' ループ用変数
Dim MaxRow As Long, MaxCol As Long
Dim tempStr As String ' 一時文字列
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
Call ClearAllFilters ' フィルター解除（テーブル・通常）
Application.StatusBar = "トリム中～"
With ActiveSheet
' 使用済み範囲のサイズ取得（開始位置考慮）
MaxRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
MaxCol = .UsedRange.Column + .UsedRange.Columns.Count - 1
' データを配列に格納
dataArray = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
' 配列内の文字列を複数回Trim（全角→半角→連続スペース除去）
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If Not IsError(dataArray(i, j)) Then
tempStr = CStr(dataArray(i, j))
If Trim(Replace(tempStr, " ", " ")) <> "" Then
tempStr = Replace(tempStr, " ", " ") ' 全角→半角スペース
tempStr = Trim(tempStr)
Do While InStr(tempStr, " ") > 0
tempStr = Replace(tempStr, " ", " ") ' 連続スペースを1つに
Loop
tempStr = Trim(tempStr)
dataArray(i, j) = tempStr
End If
End If
Next j
Next i
' 配列をシートに書き戻し
.Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value = dataArray
End With
Application.StatusBar = ""
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' アクティブシートの全セルを整形（半角スペース統一＋改行・タブ除去）
' ・ 全角スペース → 半角スペース
' ・ 改行（LF/CR/CRLF/Unicode）・タブを除去
' ・ 前後トリム（2回）で余白の余韻まで整える
' ・ 配列処理で高速化、エラー値対応
' ・ 保存前処理で安心設計、フィルター解除でズレ防止
'+++*********************************************************+++
Sub exeTrim_shtHfSpcRmBrk()
Dim ws As Worksheet
Dim rng As Range
Dim arr As Variant
Dim i As Long, j As Long
Set ws = ActiveSheet
Set rng = ws.UsedRange
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
Call ClearAllFilters ' フィルター解除（テーブル・通常）
'=== 使用範囲を配列に格納（1セルのみの場合も対応）===
If rng.Cells.Count = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
Else
arr = rng.Value
End If
'=== 配列内の各セルに対してトリム処理 ===
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
If Not IsError(arr(i, j)) And Trim(CStr(arr(i, j))) <> "" Then
' 1回目：基本のトリム（前後の空白）
arr(i, j) = Trim(CStr(arr(i, j)))
' 2回目：全角スペース・改行・タブなどの除去
arr(i, j) = Replace(arr(i, j), " ", "") ' 全角スペース
arr(i, j) = Replace(arr(i, j), vbLf, "") ' LF（Unix系）
arr(i, j) = Replace(arr(i, j), vbCr, "") ' CR（古いMac）
arr(i, j) = Replace(arr(i, j), vbCrLf, "") ' CRLF（Windows）
arr(i, j) = Replace(arr(i, j), ChrW(8232), "") ' Unicode改行（Line Separator）
arr(i, j) = Replace(arr(i, j), vbTab, "") ' タブ
' 最終仕上げ：再度トリム
arr(i, j) = Trim(CStr(arr(i, j)))
End If
Next j
Next i
'=== 配列をシートに書き戻し ===
rng.Value = arr
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 選択セルの列を整形（半角スペース統一＋改行・タブ除去）
' ・ 全角スペース → 半角スペース
' ・ 改行（LF/CR/CRLF/Unicode）・タブを除去
' ・ 連続スペースを1つに統一、前後トリム（2回）
' ・ 分割処理で大量データ対応、エラー値も安全に処理
' ・ 保存前処理で安心設計、フィルター解除でズレ防止
' ※ タイトル行の下のセルを選択して実行する
'+++*********************************************************+++
Sub exeTrim_clmHfRmBrk()
'=== 変数宣言 ===
Dim MaxRow As Long ' 選択列の最終行
Dim R As Range ' アクティブセル（選択セル）
Dim i As Long, x As Long ' ループ用変数
Dim loopMax As Long ' 分割処理のループ回数
Dim colNO As Long ' 選択列の列番号
Dim cellval As Variant ' セルの値（処理対象）
Dim myArray1 As Variant ' 元データ配列（2次元）
Dim myArray2 As Variant ' 加工後の1次元配列
Dim tmpArr As Variant ' 貼り付け用2次元配列
Dim sttRow As Long, endRow As Long ' 開始・終了行
Dim maxNo As Long: maxNo = 25000 ' 一度に処理する最大行数（分割用）
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 実行前に保存（処理前に戻せるように）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save ' ユーザーが安心して処理できるよう、事前保存
Call ClearAllFilters ' テーブル・通常フィルターを解除
'=== アクティブセルの位置情報取得 ===
Set R = ActiveCell
sttRow = R.Row ' 選択セルの行番号
colNO = R.Column ' 選択セルの列番号
With ActiveSheet
'=== 選択列の最終行を取得 ===
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 1セルのみの場合の処理 ===
If MaxRow = sttRow Then
cellval = R.Value
If Not IsError(cellval) And Trim(CStr(cellval)) <> "" Then
'=== 2回目：不要文字の除去（空白の種類を徹底的にクリーニング） ===
cellval = Replace(cellval, " ", " ") ' 全角スペース → 半角スペースに変換
cellval = Replace(cellval, vbLf, "") ' LF（Unix系改行）を除去
cellval = Replace(cellval, vbCr, "") ' CR（古いMac改行）を除去
cellval = Replace(cellval, vbCrLf, "") ' CRLF（Windows改行）を除去
cellval = Replace(cellval, ChrW(8232), "") ' Unicode改行（Line Separator）を除去
cellval = Replace(cellval, vbTab, "") ' タブ文字を除去
Do While InStr(cellval, " ") > 0
cellval = Replace(cellval, " ", " ") ' 連続スペースを1つにまとめる
Loop
R.Value = Trim(cellval) ' 最終トリム（前後の空白除去）
End If
'=== 複数セルの場合の処理 ===
Else
'=== 分割処理の回数を計算（大量データ対応） ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割ループ処理 ===
For x = 1 To loopMax
'=== 処理範囲の終了行を決定 ===
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
'=== 対象範囲を配列に格納 ===
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 各セルに対してトリム処理 ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If Not IsError(cellval) And Trim(CStr(cellval)) <> "" Then
cellval = Replace(cellval, " ", " ") ' 全角スペース → 半角スペース
cellval = Replace(cellval, vbLf, "") ' LF（Unix系改行）
cellval = Replace(cellval, vbCr, "") ' CR（古いMac改行）
cellval = Replace(cellval, vbCrLf, "") ' CRLF（Windows改行）
cellval = Replace(cellval, ChrW(8232), "") ' Unicode改行（Line Separator）
cellval = Replace(cellval, vbTab, "") ' タブ文字
Do While InStr(cellval, " ") > 0
cellval = Replace(cellval, " ", " ") ' 連続スペースを1つに
Loop
myArray2(i) = Trim(cellval) ' 最終トリム
Else
myArray2(i) = cellval ' 空白・エラーはそのまま
End If
Next i
'=== 1次元配列を縦方向の2次元配列に変換 ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
'=== 加工済みデータをシートに書き戻し ===
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
'=== メモリ解放と次の範囲へ ===
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' アクティブシート全体のセルを整形（半角スペース統一＋改行・タブ除去）
' ・ 全角スペース → 半角スペース
' ・ 改行（LF/CR/CRLF/Unicode）・タブを除去
' ・ 連続スペースを1つに統一、前後トリム（2回）
' ・ 配列処理で高速化、エラー値も安全に処理
' ・ 保存前処理で安心設計、フィルター解除でズレ防止
'+++*********************************************************+++
Sub exeTrim_shtHfRmBrk()
'=== 変数宣言 ===
Dim dataArray As Variant ' 元データを格納する2次元配列
Dim i As Long, j As Long ' ループ用変数（行・列）
Dim MaxRow As Long, MaxCol As Long ' 使用範囲の最大行・列
Dim tempStr As String ' 一時的な文字列（整形処理用）
'=== 画面更新停止・フィルター解除 ===
If IsCall = False Then Call StopUpdating
Call ClearAllFilters ' テーブル・通常フィルターを解除
'=== 実行前に保存（処理前に戻せるように）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save ' ユーザーが安心して処理できるよう、事前保存
'=== ステータスバー表示（進行状況の通知）===
Application.StatusBar = "シート全体をトリム中..."
With ActiveSheet
'=== 使用範囲のサイズ取得（UsedRangeの開始位置を考慮）===
MaxRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
MaxCol = .UsedRange.Column + .UsedRange.Columns.Count - 1
'=== 使用範囲を配列に格納（高速処理のため）===
dataArray = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value
'=== 配列内の各セルに対してトリム処理を実施 ===
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If Not IsError(dataArray(i, j)) Then
tempStr = CStr(dataArray(i, j)) ' 値を文字列化
If Trim(tempStr) <> "" Then
'=== 2回目：不要文字の除去（空白の種類を徹底的にクリーニング） ===
tempStr = Replace(tempStr, " ", " ") ' 全角スペース → 半角スペースに変換
tempStr = Replace(tempStr, vbLf, "") ' LF（Unix系改行）を除去
tempStr = Replace(tempStr, vbCr, "") ' CR（古いMac改行）を除去
tempStr = Replace(tempStr, vbCrLf, "") ' CRLF（Windows改行）を除去
tempStr = Replace(tempStr, ChrW(8232), "") ' Unicode改行（Line Separator）を除去
tempStr = Replace(tempStr, vbTab, "") ' タブ文字を除去
Do While InStr(tempStr, " ") > 0
tempStr = Replace(tempStr, " ", " ") ' 連続スペースを1つにまとめる
Loop
tempStr = Trim(tempStr) ' 最終トリム（前後の空白除去）
dataArray(i, j) = tempStr ' 加工済み文字列を配列に戻す
End If
End If
Next j
Next i
'=== 加工済み配列をシートに書き戻し ===
.Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value = dataArray
End With
'=== ステータスバーをクリア ===
Application.StatusBar = ""
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' アクティブシートの図形を消去
'+++*********************************************************+++
Sub delShp()
Dim shp As Shape
Const PROsName = "strTrim"
Application.StatusBar = "図を消去中～"
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
With ActiveSheet
For Each shp In .UsedRange
shp.Delete
Next shp
End With
Application.StatusBar = ""
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' テーブルを範囲に変換 背景色・枠線消去（理英さん仕様）
' ・アクティブシートにテーブルが1つ → 自動で変換
' ・複数ある場合 → アクティブセルがテーブル内か判定
' ・該当しない場合 → メッセージ表示
'+++*********************************************************+++
Sub UnformatTbl()
Dim lo As ListObject
Dim rng As Range
Dim tblCount As Long
Dim targetTable As ListObject
Dim isActiveCellInTable As Boolean
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
tblCount = ActiveSheet.ListObjects.Count
isActiveCellInTable = False
If tblCount = 0 Then
MsgBox "このシートにはテーブルが存在しません。", vbExclamation
Exit Sub
End If
'=== テーブルが1つだけの場合は即変換 ===
If tblCount = 1 Then
Set targetTable = ActiveSheet.ListObjects(1)
Call UnlistAndClearFormat(targetTable)
Exit Sub
End If
'=== 複数テーブルがある場合は、アクティブセルがどれかのテーブル内か確認 ===
For Each lo In ActiveSheet.ListObjects
If Not Intersect(ActiveCell, lo.Range) Is Nothing Then
isActiveCellInTable = True
Set targetTable = lo
Exit For
End If
Next lo
If isActiveCellInTable Then
Call UnlistAndClearFormat(targetTable)
Else
MsgBox "複数のテーブルが存在します。解除したいテーブル内のセルを選択してください。", vbExclamation
End If
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'--- テーブル解除＋書式クリア処理 ---
Private Sub UnlistAndClearFormat(lo As ListObject)
Dim rng As Range
Set rng = lo.Range
lo.Unlist
With rng
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone
End With
rng.Rows(1).Font.Color = vbBlack
MsgBox "テーブルを解除し、書式をクリアしました♪", vbInformation
End Sub
'+++*********************************************************+++
' 目次シートを作成（表示・非表示シートを分類）
' 行高・列幅・色指定あり／エラー処理強化Ver.
'+++*********************************************************+++
Sub getSheetTitleList()
Dim wsCont As Worksheet
Dim i As Long
Dim x As Long, y As Long
On Error GoTo getSheetTitleList_Err
If IsCall = False Then Call StopUpdating
myProcd = "getSheetTitleList"
' 目次シートがなければ新規作成
If IsSht("もくじ") = False Then
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "もくじ"
End If
Set wsCont = Worksheets("もくじ")
With wsCont
.Select '必須のSelect
.Columns(2).ClearContents
.Columns(4).ClearContents
.Range("B1").Value = ActiveWorkbook.Name
.Range("B3").Value = "― もくじ ―"
'行高の調整（静かな余白）
.Rows(2).RowHeight = 2.5
.Rows(4).RowHeight = 2.5
.Rows(5).RowHeight = 2.5
x = 6 ' 表示シートの開始行
y = 6 ' 非表示シートの開始行
With .Range("D3")
.Value = "― 非表示シート ―"
.Font.Bold = True
.Interior.Color = RGB(230, 230, 230) ' 見出しもグレー
End With
For i = 1 To Sheets.Count
If Worksheets(i).Name <> "もくじ" Then
If Worksheets(i).Visible Then
' 表示中シート → B列に記載＋リンク
.Cells(x, 2).Value = Worksheets(i).Name
.Cells(x, 2).Interior.Color = xlNone
.Hyperlinks.Add anchor:=.Cells(x, 2), Address:="", _
SubAddress:="'" & Worksheets(i).Name & "'!A1", _
TextToDisplay:=Worksheets(i).Name
.Cells(x, 2).Font.Color = vbBlue
x = x + 1
Else
' 非表示シート → D列に記載（D7）
.Cells(y, 4).Value = Worksheets(i).Name
.Cells(y, 4).Interior.Color = RGB(230, 230, 230) ' 薄いグレー
.Cells(y, 4).Font.Color = vbBlue
y = y + 1
End If
End If
Next i
'列幅の調整
.Columns(1).ColumnWidth = 1.27
.Columns(2).EntireColumn.AutoFit
.Columns(3).ColumnWidth = 1.27
.Range("A1").Select
.Select
End With
If IsCall = False Then
Call Updating
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
End If
getSheetTitleList_Exit:
'一時的にエラー無視
On Error Resume Next
Call ReSetObject
Call Updating
Exit Sub
getSheetTitleList_Err:
'【ESC】で止められた場合
If Err.Number = 18 Then
If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
DoEvents
Resume
End If
Else
MsgBox "実行時エラー:" & Err.Number & vbCrLf & _
Err.Description & vbCrLf & _
"処理を終了します。", vbExclamation, myProcd
End If
Err.Clear
GoTo getSheetTitleList_Exit
End Sub
'+++*********************************************************+++
' 文字色変更
'+++*********************************************************+++
Public Sub ChangeColor()
Dim c As Range
Dim Str1 As String
Dim Str2 As String
Dim BfrStr As String
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
Str1 = "'"
Str2 = """"
For Each c In ActiveSheet.UsedRange
'PrefixCharacterは、Rangeメンバーで接頭辞の値を取得する｡
'値自体は取得できない
If c.PrefixCharacter = "'" Then
c.Value = " " & c.Value
c.Characters(START:=1, _
Length:=Len(c)).Font.Color = 39168
End If
If InStr(c, Str1) > 0 Then
BfrStr = Left(c, InStr(c, Str1) - 1)
'ダブルクォーテーションが含まれないとき
If InStr(BfrStr, Str2) = 0 Then
c.Characters(START:=InStr(c, "'"), _
Length:=Len(c)).Font.Color = 39168
'ダブルクォーテーションが含まれるとき
ElseIf InStr(BfrStr, Str2) > 0 Then
'最後のダブルクォーテーションよりも
'シングルクォーテーションが後にある場合だけ
If InStrRev(c, Str2) < InStrRev(c, Str1) Then
c.Characters(START:=InStrRev(c, Str1), _
Length:=Len(c)).Font.Color = 39168
End If
End If
End If
Next c
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' VBAコード整形コピー（コメントのシングルクォーテーション保持）
'+++*********************************************************+++
Public Sub CopyCodeWithComments()
Dim c As Range
Dim codeLine As String
Dim fullCode As String
Dim quote As String: quote = "'"
'対象範囲（必要に応じて変更）
For Each c In Selection
If Not IsEmpty(c.Value) Then
codeLine = c.Value
'PrefixCharacterがコメントなら、強制的にシングルクォーテーションを挿入
If c.PrefixCharacter = quote Then
codeLine = quote & codeLine
ElseIf Left(codeLine, 1) = quote Then
'Prefixがないけど、文字列として ' がある場合はそのまま
End If
'コードを連結
fullCode = fullCode & codeLine & vbCrLf
End If
Next c
'クリップボードにコピー
Dim DataObj As Object
Set DataObj = CreateObject("MSForms.DataObject")
DataObj.SetText fullCode
DataObj.PutInClipboard
MsgBox "コードが整形されてコピーされました。" & vbCrLf & "コメントの ' も保持されています", vbInformation
End Sub
'+++*********************************************************+++
' TitleSimple
'+++*********************************************************+++
Public Sub TitleSimple()
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'//プリンタとの接続を切断
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = "&10&D"
.CenterHeader = "&""-,太字""&12&A"
.RightHeader = "P.&P/&N"
.LeftFooter = ""
.CenterFooter = "&10&F"
.RightFooter = ""
.LeftMargin = Application.CentimetersToPoints(1.2)
.RightMargin = Application.CentimetersToPoints(1.2)
.TopMargin = Application.CentimetersToPoints(1.8)
.BottomMargin = Application.CentimetersToPoints(1.8)
.HeaderMargin = Application.CentimetersToPoints(0.3)
.FooterMargin = Application.CentimetersToPoints(0.3)
End With
With ActiveSheet.Cells
.Font.Name = "Meiryo UI"
.Font.Size = 10
.RowHeight = 18.75
End With
With ActiveSheet
.Columns(1).ColumnWidth = 1.25
.Columns(2).ColumnWidth = 65
.Columns(2).WrapText = True
.Columns(3).ColumnWidth = 1.25
'文字色変更
Call ChangeColor
End With
'//プリンタを再接続
Application.PrintCommunication = True
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' Title
'+++*********************************************************+++
Public Sub Title()
Dim c As Range
Dim Str1 As String
Dim Str2_1 As String
Dim Str2_2 As String
Dim Str2_3 As String
Dim Str3_1 As String
Dim Str3_2 As String
Dim Str3_3 As String
Dim Str4 As String
Dim Str5 As String
Dim Str6 As String
Dim Str7_1 As String
Dim Str7_2 As String
Dim Str7_3 As String
Dim Str8_1 As String
Dim Str8_2 As String
Dim Str9_1 As String
Dim Str9_2 As String
Dim Str10 As String
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
Str1 = "Module"
Str2_1 = "Public Sub"
Str2_2 = "Praivate Sub"
Str2_3 = "Sub"
Str3_1 = "Public Function"
Str3_2 = "Praivate Function"
Str3_3 = "Function"
Str4 = "End Sub"
Str5 = "End Function"
Str6 = "Exit Sub"
Str7_1 = "On Error GoTo"
Str7_2 = "On Error Resume Next"
Str7_3 = "Resume"
Str8_1 = "Exit Sub"
Str8_2 = "Exit"
Str9_1 = "_Err"
Str9_2 = "Error"
Str10 = "Call "
If IsCall = False Then
Call StopUpdating
End If
'//プリンタとの接続を切断
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = "&10&D"
.CenterHeader = "&""-,太字""&12&A"
.RightHeader = "P.&P/&N"
.LeftFooter = ""
.CenterFooter = "&10&F"
.RightFooter = ""
.LeftMargin = Application.CentimetersToPoints(1.2)
.RightMargin = Application.CentimetersToPoints(1.2)
.TopMargin = Application.CentimetersToPoints(1.8)
.BottomMargin = Application.CentimetersToPoints(1.8)
.HeaderMargin = Application.CentimetersToPoints(0.3)
.FooterMargin = Application.CentimetersToPoints(0.3)
End With
With ActiveSheet.Cells
.Font.Name = "Meiryo UI"
.Font.Size = 10
.RowHeight = 18.75
End With
With ActiveSheet
.Columns(1).ColumnWidth = 1.25
.Columns(2).ColumnWidth = 65
.Columns(2).WrapText = True
.Columns(3).ColumnWidth = 1.25
End With
For Each c In ActiveSheet.UsedRange
Select Case True
'Str1 = "Module"
Case Left(Trim(c), Len(Str1)) = Str1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMidnightBlue
'Str2_1 = "Public Sub"
Case Left(Trim(c), Len(Str2_1)) = Str2_1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str2_2 = "Praivate Sub"
Case Left(Trim(c), Len(Str2_2)) = Str2_2
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str2_3 = "Sub"
Case Left(Trim(c), Len(Str2_3)) = Str2_3
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str3_1 = "Public Function"
Case Left(Trim(c), Len(Str3_1)) = Str3_1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str3_2 = "Praivate Function"
Case Left(Trim(c), Len(Str3_2)) = Str3_2
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str3_3 = "Function"
Case Left(Trim(c), Len(Str3_3)) = Str3_3
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str4 = "End Sub"
Case InStr(c.Value, Str4) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkSeaGreen
'Str5 = "End Function"
Case InStr(c.Value, Str5) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLavender
'Str6 = "Exit Sub"
Case InStr(c.Value, Str6) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbSilver
'Str7_1 = "On Error GoTo"
Case InStr(c.Value, Str7_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str7_2 = "On Error Resume Next"
Case InStr(c.Value, Str7_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str7_3 = "Resume"
Case InStr(c.Value, Str7_3) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str8_1 = "Exit Sub"
Case InStr(c.Value, Str8_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLightGrey
'Str8_2 = "Exit"
Case InStr(c.Value, Str8_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLightGrey
'Str9_1 = "_Err"
Case InStr(c.Value, Str9_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbPaleGoldenrod
'Str9_2 = "Error"
Case InStr(c.Value, Str9_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbPaleGoldenrod
'Str10 = "Call "
Case Left(Trim(c), Len(Str10)) = Str10
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLavenderBlush
End Select
Next c
'文字色変更をCall
Call ChangeColor
'//プリンタを再接続
Application.PrintCommunication = True
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' Title セル幅設定なし
'+++*********************************************************+++
Public Sub TitleColor()
Dim c As Range
Dim Str1 As String
Dim Str2_1 As String
Dim Str2_2 As String
Dim Str2_3 As String
Dim Str3_1 As String
Dim Str3_2 As String
Dim Str3_3 As String
Dim Str4 As String
Dim Str5 As String
Dim Str6 As String
Dim Str7_1 As String
Dim Str7_2 As String
Dim Str7_3 As String
Dim Str8_1 As String
Dim Str8_2 As String
Dim Str9_1 As String
Dim Str9_2 As String
Dim Str10 As String
If IsCall = False Then
Call StopUpdating
End If
Str1 = "Module"
Str2_1 = "Public Sub"
Str2_2 = "Praivate Sub"
Str2_3 = "Sub"
Str3_1 = "Public Function"
Str3_2 = "Praivate Function"
Str3_3 = "Function"
Str4 = "End Sub"
Str5 = "End Function"
Str6 = "Exit Sub"
Str7_1 = "On Error GoTo"
Str7_2 = "On Error Resume Next"
Str7_3 = "Resume"
Str8_1 = "Exit Sub"
Str8_2 = "Exit"
Str9_1 = "_Err"
Str9_2 = "Error"
Str10 = "Call "
If IsCall = False Then
Call StopUpdating
End If
'//プリンタとの接続を切断
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = "&10&D"
.CenterHeader = "&""-,太字""&12&A"
.RightHeader = "P.&P/&N"
.LeftFooter = ""
.CenterFooter = "&10&F"
.RightFooter = ""
.LeftMargin = Application.CentimetersToPoints(1.2)
.RightMargin = Application.CentimetersToPoints(1.2)
.TopMargin = Application.CentimetersToPoints(1.8)
.BottomMargin = Application.CentimetersToPoints(1.8)
.HeaderMargin = Application.CentimetersToPoints(0.3)
.FooterMargin = Application.CentimetersToPoints(0.3)
End With
With ActiveSheet.Cells
.Font.Name = "Meiryo UI"
.Font.Size = 10
'' .RowHeight = 18.75
End With
With ActiveSheet
'' .Columns(1).ColumnWidth = 1.25
'' .Columns(2).ColumnWidth = 65
'' .Columns(2).WrapText = True
'' .Columns(3).ColumnWidth = 1.25
'文字色変更
Call ChangeColor
End With
For Each c In ActiveSheet.UsedRange
Select Case True
'Str1 = "Module"
Case Left(Trim(c), Len(Str1)) = Str1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMidnightBlue
'Str2_1 = "Public Sub"
Case Left(Trim(c), Len(Str2_1)) = Str2_1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str2_2 = "Praivate Sub"
Case Left(Trim(c), Len(Str2_2)) = Str2_2
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str2_3 = "Sub"
Case Left(Trim(c), Len(Str2_3)) = Str2_3
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkTurquoise
'Str3_1 = "Public Function"
Case Left(Trim(c), Len(Str3_1)) = Str3_1
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str3_2 = "Praivate Function"
Case Left(Trim(c), Len(Str3_2)) = Str3_2
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str3_3 = "Function"
Case Left(Trim(c), Len(Str3_3)) = Str3_3
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbMediumSlateBlue
'Str4 = "End Sub"
Case InStr(c.Value, Str4) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbDarkSeaGreen
'Str5 = "End Function"
Case InStr(c.Value, Str5) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLavender
'Str6 = "Exit Sub"
Case InStr(c.Value, Str6) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbSilver
'Str7_1 = "On Error GoTo"
Case InStr(c.Value, Str7_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str7_2 = "On Error Resume Next"
Case InStr(c.Value, Str7_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str7_3 = "Resume"
Case InStr(c.Value, Str7_3) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbAzure
'Str8_1 = "Exit Sub"
Case InStr(c.Value, Str8_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLightGrey
'Str8_2 = "Exit"
Case InStr(c.Value, Str8_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLightGrey
'Str9_1 = "_Err"
Case InStr(c.Value, Str9_1) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbPaleGoldenrod
'Str9_2 = "Error"
Case InStr(c.Value, Str9_2) > 0
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbPaleGoldenrod
'Str10 = "Call "
Case Left(Trim(c), Len(Str10)) = Str10
c.Font.Color = vbWhite
c.Resize(1, 3).Offset(0, -1).Interior.Color = rgbLavenderBlush
End Select
Next c
'文字色変更をCall
Call ChangeColor
'//プリンタを再接続
Application.PrintCommunication = True
If IsCall = False Then
Call Updating
'最小化
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
End If
End Sub
'+++*********************************************************+++
' 最右シートに移動
'+++*********************************************************+++
Sub GotoLstSht()
Dim i As Long
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
With ActiveWorkbook
'一時的にエラー無視
On Error Resume Next
For i = 1 To .Worksheets.Count
If .Worksheets(i).Visible = True Then
.Worksheets(i).Select
Application.GoTo reference:=Range("A1"), _
Scroll:=True
Exit For
End If
Next i
'エラーハンドリング解除
On Error GoTo 0
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
'+++*********************************************************+++
' 登録した印章画像を選択範囲に押印
'+++*********************************************************+++
Sub AddPictureSampLinkPaste()
Dim myFileName As String
Dim myShape As Shape
Dim myC As Range
Dim myTop As Double
Dim myLeft As Double
'画像の保存先を記入↓
myFileName = "C:\Users\XXX\画像\ねこ印.png"
Set myC = ActiveCell
myTop = myC.Top + (myC.Height - 34) / 2
myLeft = myC.Left + (myC.Width - 34) / 2
'--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
Set myShape = ActiveSheet.Shapes.AddPicture( _
FileName:=myFileName, _
LinkToFile:=True, _
SaveWithDocument:=False, _
Left:=myLeft, _
Top:=myTop, _
Width:=0, _
Height:=0)
'--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
With myShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
End Sub
'+++*********************************************************+++
' シートにあるマクロコードをコピーする際に使用
'+++*********************************************************+++
Public Sub ExportCodeToText()
Dim c As Range
Dim codeLine As String
Dim fullCode As String
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
For Each c In Selection
If Not IsEmpty(c.Value) Then
codeLine = c.Value
' コメント補完
If c.PrefixCharacter = "'" Then
codeLine = "'" & codeLine
End If
' 空行除去（必要なら）
If Trim(codeLine) <> "" Then
fullCode = fullCode & codeLine & vbCrLf
End If
End If
Next c
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
' 出力（ファイル保存やクリップボードなど）
MsgBox "整形されたコードが準備できました"
End Sub
'+++*********************************************************+++
' 選択セルの列をコピー（テーブル対応）
'+++*********************************************************+++
Sub CopyRangeFromTableOrColumn()
Dim ws As Worksheet
Dim tbl As ListObject
Dim rngToCopy As Range
Dim currentCell As Range
Dim lastRow As Long
Dim colNum As Long
Set ws = ActiveSheet
Set currentCell = ActiveCell
'エラーハンドリング解除
colNum = currentCell.Column
'一時的にエラー無視
On Error Resume Next
Set tbl = currentCell.ListObject
'エラーハンドリング解除
On Error GoTo 0
If Not tbl Is Nothing Then
' テーブル内の場合：テーブルの最終行までコピー
lastRow = tbl.Range.Row + tbl.Range.Rows.Count - 1
Set rngToCopy = ws.Range(currentCell, ws.Cells(lastRow, colNum))
Else
' テーブル外の場合：列の最終行までコピー
lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
Set rngToCopy = ws.Range(currentCell, ws.Cells(lastRow, colNum))
End If
rngToCopy.Copy
MsgBox "コピーしました：" & rngToCopy.Address, vbInformation
' オブジェクト解放
Set rngToCopy = Nothing
Set tbl = Nothing
Set currentCell = Nothing
Set ws = Nothing
End Sub
'+++*********************************************************+++
' アクティブシートの初期化処理
' テーブル（ListObject）も消去
'+++*********************************************************+++
Sub CleanActSheet()
Dim lo As ListObject
Dim shp As Shape
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
'=== クリーニング処理 ===
On Error Resume Next '一時的にエラー無視（テーブル未存在時など）
With ActiveSheet
' テーブル削除（存在する場合）
If .ListObjects.Count > 0 Then
For Each lo In .ListObjects
lo.Delete
Next lo
End If
' セル内容・書式を全クリア
.Cells.Clear
End With
'エラーハンドリング解除
On Error GoTo 0
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
MsgBox "シートのクリーニングが完了しました ♪", vbInformation
End Sub
'+++*********************************************************+++
' アクティブシートの初期化処理
' ・ 再計算なしで保存（高速）
' ・ テーブル（ListObject）・シェイプ・セル内容を完全消去
'+++*********************************************************+++
Sub CleanActSheetPlus()
Dim lo As ListObject
Dim shp As Shape
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
'=== クリーニング処理 ===
On Error Resume Next '一時的にエラー無視（テーブル未存在時など）
With ActiveSheet
' テーブル削除（存在する場合）
If .ListObjects.Count > 0 Then
For Each lo In .ListObjects
lo.Delete
Next lo
End If
' セル内容・書式を全クリア
.Cells.Clear
' シェイプ削除（存在する場合）
If .Shapes.Count > 0 Then
For Each shp In .Shapes
shp.Delete
Next shp
End If
End With
'エラーハンドリング解除
On Error GoTo 0
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
MsgBox "シートのクリーニングが完了しました ♪", vbInformation
End Sub
'+++*********************************************************+++
' 選択セルのテーブル列名を別シートに書き出し、テーブル化
' ・テーブルが1つ → 即処理
' ・複数ある場合 → アクティブセルがテーブル内か確認
' ・該当しない場合 → メッセージ表示
' ・新シート名：テーブル名_列名
' ・A列：NO（1から連番）／B列：列名
' ・テーブル名はシート名と同じに設定
'+++*********************************************************+++
Sub ExportTableHeaders()
Dim lo As ListObject
Dim targetTable As ListObject
Dim tblCount As Long
Dim isActiveCellInTable As Boolean
Dim sheetName As String
Dim wsNew As Worksheet
Dim i As Long
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
tblCount = ActiveSheet.ListObjects.Count
isActiveCellInTable = False
If tblCount = 0 Then
MsgBox "このシートにはテーブルが存在しません。", vbExclamation
Exit Sub
End If
'=== テーブルが1つだけの場合は即処理 ===
If tblCount = 1 Then
Set targetTable = ActiveSheet.ListObjects(1)
Else
'=== 複数テーブルがある場合は、アクティブセルがどれかのテーブル内か確認 ===
For Each lo In ActiveSheet.ListObjects
If Not Intersect(ActiveCell, lo.Range) Is Nothing Then
isActiveCellInTable = True
Set targetTable = lo
Exit For
End If
Next lo
If Not isActiveCellInTable Then
MsgBox "複数のテーブルがあります。列名を抽出したいテーブル内のセルを選択してください。", vbExclamation
Exit Sub
End If
End If
'=== 新しいシート名を作成 ===
sheetName = targetTable.Name & "_列名"
'=== 同名シートが存在する場合は削除 ===
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sheetName).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'=== 新しいシートを追加 ===
Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsNew.Name = sheetName
'=== ヘッダー書き出し ===
wsNew.Range("A1").Value = "NO"
wsNew.Range("B1").Value = "列名"
For i = 1 To targetTable.HeaderRowRange.Columns.Count
wsNew.Cells(i + 1, 1).Value = i
wsNew.Cells(i + 1, 2).Value = targetTable.HeaderRowRange.Cells(1, i).Value
Next i
'=== テーブル化して名前を設定 ===
Dim loNew As ListObject
Set loNew = wsNew.ListObjects.Add(xlSrcRange, wsNew.Range("A1").CurrentRegion, , xlYes)
loNew.Name = sheetName
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
MsgBox "列名を '" & sheetName & "' シートに書き出しました♪", vbInformation
End Sub
'+++*******************************************************+++
' 処理名：AddStampToActiveCell（選択セルに印章画像を押印）
'
' 概要 ：指定された画像ファイルを、選択セルの中央に押印する。
' 画像はリンク貼り付けで、元サイズを維持。
'
' 引数 ：なし（ActiveCell を対象）
' 備考 ：画像サイズは固定（高さ・幅＝元画像）
' 画像ファイルパスは事前に指定
' 作成者：AIの共同制作
'+++*******************************************************+++
Sub AddStampToActiveCell()
Const STAMP_PATH As String = "C:\Users\＊＊＊\OneDrive\画像\ねこ印.png"
Const STAMP_SIZE As Double = 34 '中央配置用の仮サイズ（画像の実サイズで上書きされる）
Dim targetCell As Range
Dim stampShape As Shape
Dim posTop As Double, posLeft As Double
'=== 前処理：画面更新停止（外部プロシージャ） ===
If IsCall = False Then Call StopUpdating
'▼対象セルの取得
Set targetCell = ActiveCell
'▼中央配置座標の計算（仮サイズで初期位置）
posTop = targetCell.Top + (targetCell.Height - STAMP_SIZE) / 2
posLeft = targetCell.Left + (targetCell.Width - STAMP_SIZE) / 2
'▼画像挿入（リンク貼り付け・元サイズで表示）
Set stampShape = ActiveSheet.Shapes.AddPicture( _
FileName:=STAMP_PATH, _
LinkToFile:=True, _
SaveWithDocument:=False, _
Left:=posLeft, _
Top:=posTop, _
Width:=0, _
Height:=0)
'▼元画像サイズにスケール調整
With stampShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
'=== 後処理 ===
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
If IsCall = False Then Call Updating
End Sub
コメント