Base Procedure Set 1
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【XXX_MakeBase】に変更する。
モジュール名：XXX_MakeBase
Option Explicit
'*****************************************************
' MaxRow , MaxColの取得と範囲指定の詩的テンプレート
'*****************************************************
Sub exeMax()
Dim shtName As String 'シート名（未使用）
Dim MaxRow As Long '最終行
Dim MaxCol As Long '最終列
Dim rMaxRow As Long '一時的な最大行
Dim j As Long '列ループ用
With ActiveSheet
'通常使用
'-----------------------------------------------------
' A列基準の最終行
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' 1行目基準の最終列
MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'-----------------------------------------------------
' UsedRangeから最終行・最終列（ただし信頼性に注意）
With .UsedRange
MaxRow = .Rows(.Rows.Count).Row
MaxCol = .Columns(.Columns.Count).Column
End With
'-----------------------------------------------------
' より正確な最終行取得（各列を調べて最大値を取る）
'Dim j As Long
'Dim r As Long
'Dim MaxRow As Long
'Dim rMax As Long
MaxRow = 0
For j = 1 To MaxCol
rMaxRow = .Cells(.Rows.Count, j).End(xlUp).Row
If rMaxRow > MaxRow Then
MaxRow = rMaxRow
End If
Next j
'-----------------------------------------------------
' アクティブセル基準の範囲取得
Dim ws As Worksheet
Dim currentCell As Range
Dim rowNum As Long, colNum As Long
Dim myRange As Range, tblRange As Range
Set ws = ActiveSheet
Set currentCell = ActiveCell
rowNum = currentCell.Row
colNum = currentCell.Column
' 選択セルの列基準 最終行
MaxRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
' 選択セルの行基準 最終列
MaxCol = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
' 選択セルから右下方向にテーブル範囲
Set tblRange = .Range(currentCell, .Cells(MaxRow, MaxCol))
' 選択セルから同じ列の最終行まで
Set myRange = .Range(currentCell, .Cells(MaxRow, currentCell.Column))
' 選択セルから同じ行の最終列まで
Set myRange = .Range(currentCell, .Cells(currentCell.Row, MaxCol))
' 選択セルから固定サイズ（10行×5列）
Set myRange = .Range(currentCell, currentCell.Offset(9, 4))
'-----------------------------------------------------
' 特定セル（例：5行1列）からの最終行・列
MaxRow = .Cells(5, 1).End(xlDown).Row
MaxCol = .Cells(5, 1).End(xlToRight).Column
'-----------------------------------------------------
' アクティブセルを含むデータ範囲（CurrentRegion）
'「Ctrl」＋「Shift」＋ [*]キー(テンキーではないほうの*）で
'選択される範囲
.Cells(rowNum, colNum).CurrentRegion.Select
' 使用済み範囲の選択（Ctrl+Shift+End 相当）
.Range(.Cells(1, 1), .Cells(1, 1).SpecialCells(xlLastCell)).Select
'使用済み範囲の選択
'1.アクティブセルをセルA1に移動します
'2.[Ctrl]+[Shift］キーを押しながら［End」キーを押します
.Range(.Cells(1, 1), .Cells(1, 1).SpecialCells(xlLastCell)).Select
'-----------------------------------------------------
' スクロールして先頭に移動
Application.GoTo reference:=.Range("A1"), Scroll:=True
End With
End Sub
'=====================================================
' シンプルな黒の罫線
' Range ("A1:C3").Borders.LineStyle = xlContinuous
'=====================================================
'*****************************************************
' 範囲 参照用
'*****************************************************
Sub Basic()
Dim rng As Range '範囲
With ActiveSheet
'通常使用
Set rng = .Range(.Cells(1, 1), Cells(3, 2)) 'セルA1-B3の範囲
Set rng = .Range("A1") 'セルA1
Set rng = .Range("名前定義") '名前定義の範囲
Set rng = .Range("A1 : B3") 'セルA1-B3の範囲
Set rng = .Range("A1, B3") 'セルA1,B3の範囲
Set rng = .Range(.Rows(1), .Rows(3)) '1-3行の範囲
Set rng = .Range(.Columns(1), .Columns(3)) 'A-C列の範囲
Set rng = .Range("1:3") '1-3行の範囲
Set rng = .Range("A:C") '1-3列の範囲
Set rng = .Rows(5) '5行目の範囲
Set rng = .Rows("1:5") '1-5行目の範囲
Set rng = .Columns(3) '3列の範囲
Set rng = .Columns("C") '3列の範囲
Set rng = .Columns("A: C") '1-3列の範囲
'x : .Columns("1:3") '使えないNG
'◆ セルのオフセット指定 (相対位置)
Set rng = .Range("A1").Offset(1, 2) 'A1から1行下・2列右 → C2
Set rng = .Range("A1").Offset(0, 0).Resize(3, 2) 'A1から3行2列の範囲 → A1:B3
'◆ Union（複数範囲の結合）
Set rng = Union(.Range("A1"), .Range("C3")) 'A1とC3を結合した範囲
Set rng = Union(.Rows(1), .Rows(3)) '1行目と3行目
Set rng = Union(.Columns("A"), .Columns("C")) 'A列とC列
'◆ Intersect（交差範囲の取得）
Set rng = Intersect(.Range("A1:C3"), .Range("B2:D4")) '交差範囲 → B2:C3
'◆ UsedRange（使用されている範囲）
Set rng = .UsedRange 'アクティブシートで使用されている範囲
'◆ SpecialCells（特定セルの抽出）
Set rng = .UsedRange.SpecialCells(xlCellTypeConstants) '定数が入力されたセル
Set rng = .UsedRange.SpecialCells(xlCellTypeFormulas) '数式が入力されたセル
End With
End Sub
'*****************************************************
' アクティブブック内に指定シートが存在するか確認する儀式
' 使用例：If SheetExistsInActiveBook("集計") Then ...
'*****************************************************
Public Function SheetExistsInActiveBook(shtName As String) As Boolean
Dim sht As Worksheet
SheetExistsInActiveBook = False
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = shtName Then
SheetExistsInActiveBook = True
Exit Function
End If
Next sht
End Function
'+++***********************************************+++
' 指定ブック内に指定シートが存在するか確認する儀式
' 使用例：If SheetExistsInNamedBook("集計", "myBook.xlsx") Then ...
'+++***********************************************+++
Public Function SheetExistsInNamedBook(shtName As String, wbName As String) As Boolean
Dim sht As Worksheet
Dim Owb As Workbook
'一時的にエラー無視
On Error Resume Next
Set Owb = Workbooks(wbName)
'エラーハンドリング解除
On Error GoTo 0
If Owb Is Nothing Then
SheetExistsInNamedBook = False
Exit Function
End If
For Each sht In Owb.Worksheets
If sht.Name = shtName Then
SheetExistsInNamedBook = True
Exit Function
End If
Next sht
End Function
'*****************************************************
' シート存在確認
'*****************************************************
Public Function IsSht(shtName As String) As Boolean
Dim sht As Worksheet
IsSht = False
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = shtName Then
IsSht = True
Exit Function
End If
Next sht
End Function
'+++***********************************************+++
' シート検出
' Call IsShtOwb(shtName, wbName )
'+++***********************************************+++
Public Function IsShtOwb(shtName As String, wbName As String) As Boolean
Dim sht As Worksheet
Dim Owb As Workbook
IsShtOwb = False
Set Owb = Workbooks(wbName)
For Each sht In Owb.Worksheets
If sht.Name = shtName Then
IsShtOwb = True
Set Owb = Nothing
Exit Function
End If
Next sht
'一時的にエラー無視
On Error Resume Next
Set Owb = Nothing
'エラーハンドリング解除
On Error GoTo 0
End Function
'*****************************************************
' 指定ブックを開いて処理し、変更せずに閉じる儀式
' ・存在確認、開いているかの確認
' ・処理後は静かに閉じる
'*****************************************************
Sub SampleBookOpen()
Dim buf As String
Dim TargetPath As String
Dim TargetName As String
Dim TargetBook As Workbook
Dim wb As Workbook
Dim IsOpen As Boolean
'◆ 対象ファイルのフルパスと名前
TargetPath = "C:\xxx\myBook.xlsx"
TargetName = "myBook.xlsx"
IsOpen = False
'◆ 画面更新停止（外部プロシージャ）
Call StopUpdating
'◆ ファイルの存在確認
buf = Dir(TargetPath)
If buf = "" Then
MsgBox TargetPath & vbCrLf & "は存在しません。", vbExclamation
Call Updating
Exit Sub
End If
'◆ すでに開かれているか確認
For Each wb In Workbooks
If wb.Name = TargetName Then
Set TargetBook = wb
IsOpen = True
Exit For
End If
Next wb
'◆ 開かれていなければ開く（読み取り専用でも可）
If IsOpen = False Then
Set TargetBook = Workbooks.Open(TargetPath, ReadOnly:=True)
End If
'◆ 対象ブックへの処理（ここに処理内容を記述）
'例：Debug.Print TargetBook.Sheets(1).Range("A1").Value
'◆ 開いたブックを変更せずに閉じる（開いていた場合は閉じない）
If IsOpen = False Then
TargetBook.Close SaveChanges:=False
End If
'◆ 画面更新再開（外部プロシージャ）
Call Updating
End Sub
'*****************************************************
' 指定フォルダ内のすべてのExcelファイルを記録する儀式
' ・対象：.xls, .xlsx, .xlsm など
' ・出力：アクティブシートの1列目にファイル名を並べる
'*****************************************************
Sub SampleAllFilePros()
Dim buf As String
Dim myPath As String
Dim cnt As Long
'◆ フォルダパス（末尾に \ を忘れずに）
myPath = "C:\Sample\"
'◆ ファイル名の初回取得（*.xls? は .xls, .xlsx, .xlsm に対応）
buf = Dir(myPath & "*.xls?")
'◆ 出力開始位置
cnt = 1
'◆ ファイルが見つかる限り、記録を続ける
Do While buf <> ""
Cells(cnt, 1).Value = buf
cnt = cnt + 1
buf = Dir()
Loop
MsgBox "ファイル一覧の取得が完了しました。", vbInformation
End Sub
'*****************************************************
' strMyVlook: 文字列を対象とした柔らかなVLOOKUP
' 使用例：strMyVlook("探す文字", "A2:B8", 2)
' CVErr(xlErrRef) ' → #REF!（参照エラー）
' CVErr(xlErrNA) ' → #N/A（該当なし）
' CVErr(xlErrValue) ' → #VALUE!（型エラー）
' CVErr(xlErrDiv0) ' → #DIV/0!（ゼロ除算）
'*****************************************************
Public Function strMyVlook(skey As String, strRng As String, myN As Long) As Variant
Dim vRng As Range
'一時的にエラー無視
On Error Resume Next
Set vRng = Range(strRng)
'エラーハンドリング解除
On Error GoTo 0
If vRng Is Nothing Then
strMyVlook = CVErr(xlErrRef) '範囲が無効
Exit Function
End If
If WorksheetFunction.CountIf(vRng.Columns(1), skey) > 0 Then
strMyVlook = Application.WorksheetFunction.VLookup(skey, vRng, myN, False)
Else
strMyVlook = CVErr(xlErrNA) '見つからない場合
End If
End Function
'*****************************************************
' lngMyVlook: 数値を対象とした柔らかなVLOOKUP
' 使用例：lngMyVlook(123, "A2:B8", 2)
' CVErr(xlErrRef) ' → #REF!（参照エラー）
' CVErr(xlErrNA) ' → #N/A（該当なし）
' CVErr(xlErrValue) ' → #VALUE!（型エラー）
' CVErr(xlErrDiv0) ' → #DIV/0!（ゼロ除算）
'*****************************************************
Public Function lngMyVlook(lngkey As Long, strRng As String, myN As Long) As Variant
Dim vRng As Range
'一時的にエラー無視
On Error Resume Next
Set vRng = Range(strRng)
'エラーハンドリング解除
On Error GoTo 0
If vRng Is Nothing Then
lngMyVlook = CVErr(xlErrRef) '範囲が無効
Exit Function
End If
If WorksheetFunction.CountIf(vRng.Columns(1), lngkey) > 0 Then
lngMyVlook = Application.WorksheetFunction.VLookup(lngkey, vRng, myN, False)
Else
lngMyVlook = CVErr(xlErrNA) '見つからない場合
End If
End Function
'*****************************************************
' mySoftVlook: 数値・文字列どちらも対応する柔らかVLOOKUP
' 使用例：mySoftVlook(123, "A2:B8", 2)
'*****************************************************
Public Function mySoftVlook(myKey As Variant, strRng As String, myN As Long) As Variant
Dim vRng As Range
'一時的にエラー無視
On Error Resume Next
Set vRng = Range(strRng)
'エラーハンドリング解除
On Error GoTo 0
If vRng Is Nothing Then
mySoftVlook = CVErr(xlErrRef) '範囲が無効
Exit Function
End If
If WorksheetFunction.CountIf(vRng.Columns(1), myKey) > 0 Then
mySoftVlook = Application.WorksheetFunction.VLookup(myKey, vRng, myN, False)
Else
mySoftVlook = CVErr(xlErrNA) '見つからない場合
End If
End Function
'*****************************************************
' アクティブシートの図形の名前と位置を記録する儀式
' ・左位置（Left）と上位置（Top）を取得
' ・配置の美しさを見直すための観察
'*****************************************************
Public Sub TopAndLeftSample()
Dim shp As Shape
Dim strLog As String
'◆ 図形が存在しない場合は、そっと終了
If ActiveSheet.Shapes.Count = 0 Then
Debug.Print "このシートには図形がありません。"
Exit Sub
End If
Debug.Print "◆ 図形配置ログ（名前：Left, Top）"
Debug.Print String(40, "-")
'◆ 図形の名前と位置を記録
For Each shp In ActiveSheet.Shapes
strLog = shp.Name & "：" & _
"Left=" & Format(shp.Left, "0.0") & " / " & _
"Top=" & Format(shp.Top, "0.0")
Debug.Print strLog
Next shp
End Sub
'*****************************************************
' 図形の位置と名前を取得2
'*****************************************************
Public Sub TopAndLeftSample2()
Dim shp As Shape
'アクティブシート内の図形/画像の中心位置をピクセル単位で取得
For Each shp In ActiveSheet.Shapes
Debug.Print shp.Name & ":" & (shp.Left + shp.Width / 2) & "," _
& (shp.Top + shp.Height / 2)
Next shp
End Sub
'''*****************************************************
''' Find関数設定Test
'''*****************************************************
''Sub TestFind()
'' Debug.Print FindRow("Main", "A:C", "合計", xlValues)
'' Debug.Print FindRow("Main", "A:C", "個人 計", xlValues)
''End Sub
'''*****************************************************
''' Find関数設定
''' Find関数で､ データを検索し、その行番号を返す
''' 引数:対象シート､対象列､検索データ､検索形式
''' (LookIn:xlFormula:数式,xlValues:値,xlComents:コメント文）
''' (LookAt:xlPart:部分一致,xlwhole:全体一致するセルを検索）
''' 戻り値: 行番号
''' FRow =FindRow ("Main","A","what",xlValues)
'''*****************************************************
''Public Function FindRow(shtName As String, sCol As String, ChkData As Variant, _
'' varLookIn As Variant) As Long
'' Dim tgtSht As Worksheet
'' On Error Resume Next
'' FindRow = 0
'' Set tgtSht = ThisWorkbook.Worksheets(shtName)
'' With tgtSht
'' If WorksheetFunction.CountIf(.Columns(sCol), ChkData) > 0 Then
'' FindRow = .Columns(sCol).Find(What:=ChkData, _
'' LookIn:=varLookIn, LookAt:=xlPart).Row
'' End If
'' End With
'' Set tgtSht = Nothing
''End Function
'''*****************************************************
''' Find関数設定
''' Find関数で､ データを検索し、その列番号を返す
''' 引数:対象シート､対象列､検索データ､検索形式
''' (Lookln:xlFormula:数式,xlValues:値,xlComents:コメント文）
''' (LookAt:xlPart:部分一致,xlwhole:全体一致するセルを検索）
''' 戻り値: 列番号
''' FCol =FindCol ("Main", 2, "what", xlValues)
'''*****************************************************
''Public Function FindCol(shtName As String, iRow As Long, ChkData As Variant, _
'' varLookIn As Variant) As Long
'' Dim tgtSht As Worksheet
'' On Error Resume Next
'' FindCol = 0
'' Set tgtSht = ThisWorkbook.Worksheets(shtName)
'' With tgtSht
'' If WorksheetFunction.CountIf(.Rows(iRow), ChkData) > 0 Then
'' FindCol = .Rows(iRow).Find(What:=ChkData, _
'' LookIn:=varLookIn, LookAt:=xlPart).Column
'' End If
'' End With
'' Set tgtSht = Nothing
''End Function
'*****************************************************
' Find関数のテスト：行・列の検索結果を表示
'*****************************************************
Sub TestFind()
' Debug.Print FindRow("Main", "A:C", "合計", xlValues)
' Debug.Print FindRow("Main", "A:C", "個人 計", xlValues)
' Debug.Print FindCol("Main", 2, "合計", xlValues)
' Debug.Print FindCol("Main", 1, "個人 計", xlValues)
End Sub
Sub TestSmartFind()
Dim myKey As Long
myKey = 123
MsgBox FindColW_Smart("Intra-martクエリ", 3, myKey, xlValues)
End Sub
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
' Smart Ver.検索について
' Variant 型の ChkData は、数値でも文字列でもOK。
' でも､セルの中身と型が違うと見つからないことがあるので､CStr で補完しています｡
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'****************************************************************************
' ■■ Smart Ver. ①：FindRowP_Smart（部分一致・行番号）■■
' Partial（部分一致）: LookAt:=xlPart
' FindRowP_Smart：指定シートの列範囲からデータを検索し、行番号を返す
' 使用例：
' Dim myKey As Variant
' myKey = "合計"
' FRow = FindRowP_Smart("Main", "A:C", myKey, xlValues)
' 引数：
' shtName ：検索対象のシート名
' sCol ：検索対象の列（"A" や "A:C" など）
' ChkData ：検索する値（文字列や数値）
' varLookIn ：検索形式（xlValues, xlFormulas など）
' 戻り値：
' 見つかった場合：そのセルの行番号
' 見つからない場合：0
'****************************************************************************
Public Function FindRowP_Smart(shtName As String, sCol As String, ChkData As Variant, _
varLookIn As Variant) As Long
Dim tgtSht As Worksheet
Dim tgtCell As Range
FindRowP_Smart = 0
'一時的にエラー無視
On Error Resume Next
Set tgtSht = ActiveWorkbook.Worksheets(shtName)
'エラーハンドリング解除
On Error GoTo 0
If tgtSht Is Nothing Then Exit Function
With tgtSht
Set tgtCell = .Columns(sCol).Find(ChkData, LookIn:=varLookIn, LookAt:=xlPart)
If tgtCell Is Nothing Then
Set tgtCell = .Columns(sCol).Find(CStr(ChkData), LookIn:=varLookIn, LookAt:=xlPart)
End If
If Not tgtCell Is Nothing Then
FindRowP_Smart = tgtCell.Row
End If
End With
End Function
'****************************************************************************
' ■■ Smart Ver. ②：FindRowW_Smart（完全一致・行番号）■■
' Whole（完全一致）: LookAt:=xlWhole
' FindRowW_Smart：指定シートの列範囲からデータを検索し、行番号を返す
' 使用例：
' Dim myKey As Variant
' myKey = "合計"
' FRow = FindRowW_Smart("Main", "A:C", myKey, xlValues)
'****************************************************************************
Public Function FindRowW_Smart(shtName As String, sCol As String, ChkData As Variant, _
varLookIn As Variant) As Long
Dim tgtSht As Worksheet
Dim tgtCell As Range
FindRowW_Smart = 0
'一時的にエラー無視
On Error Resume Next
Set tgtSht = ActiveWorkbook.Worksheets(shtName)
'エラーハンドリング解除
On Error GoTo 0
If tgtSht Is Nothing Then Exit Function
With tgtSht
Set tgtCell = .Columns(sCol).Find(ChkData, LookIn:=varLookIn, LookAt:=xlWhole)
If tgtCell Is Nothing Then
Set tgtCell = .Columns(sCol).Find(CStr(ChkData), LookIn:=varLookIn, LookAt:=xlWhole)
End If
If Not tgtCell Is Nothing Then
FindRowW_Smart = tgtCell.Row
End If
End With
End Function
'****************************************************************************
' ■■ Smart Ver. ③：FindColP_Smart（部分一致・列番号）■■
' Partial（部分一致）: LookAt:=xlPart
' FindColP_Smart：指定シートの行からデータを検索し、列番号を返す
' 使用例：
' Dim myKey As Variant
' myKey = "合計"
' FCol = FindColP_Smart("Main", 2, myKey, xlValues)
'****************************************************************************
Public Function FindColP_Smart(shtName As String, iRow As Long, ChkData As Variant, _
varLookIn As Variant) As Long
Dim tgtSht As Worksheet
Dim tgtCell As Range
FindColP_Smart = 0
'一時的にエラー無視
On Error Resume Next
Set tgtSht = ActiveWorkbook.Worksheets(shtName)
'エラーハンドリング解除
On Error GoTo 0
If tgtSht Is Nothing Then Exit Function
With tgtSht
Set tgtCell = .Rows(iRow).Find(ChkData, LookIn:=varLookIn, LookAt:=xlPart)
If tgtCell Is Nothing Then
Set tgtCell = .Rows(iRow).Find(CStr(ChkData), LookIn:=varLookIn, LookAt:=xlPart)
End If
If Not tgtCell Is Nothing Then
FindColP_Smart = tgtCell.Column
End If
End With
End Function
'*****************************************************
' ■■ Smart Ver. ④：FindColW_Smart（完全一致・列番号）■■
' Whole（完全一致）: LookAt:=xlWhole
' FindColW_Smart：指定シートの行からデータを検索し、列番号を返す
' 使用例：
' Dim myKey As Variant
' myKey = "合計"
' FCol = FindColW_Smart("Main", 2, myKey, xlValues)
'*****************************************************
Public Function FindColW_Smart(shtName As String, iRow As Long, ChkData As Variant, _
varLookIn As Variant) As Long
Dim tgtSht As Worksheet
Dim tgtCell As Range
FindColW_Smart = 0
'一時的にエラー無視
On Error Resume Next
Set tgtSht = ActiveWorkbook.Worksheets(shtName)
'エラーハンドリング解除
On Error GoTo 0
If tgtSht Is Nothing Then Exit Function
With tgtSht
Set tgtCell = .Rows(iRow).Find(ChkData, LookIn:=varLookIn, LookAt:=xlWhole)
If tgtCell Is Nothing Then
Set tgtCell = .Rows(iRow).Find(CStr(ChkData), LookIn:=varLookIn, LookAt:=xlWhole)
End If
If Not tgtCell Is Nothing Then
FindColW_Smart = tgtCell.Column
End If
End With
End Function
'*****************************************************
' SampleSort：Excelのバージョンに応じて並び替え
'*****************************************************
Sub SampleSort()
If val(Application.Version) < 16 Then
'Excel 2016以前
Call SampleSort2016
Else
'Excel 365以降
Call SampleSort365
End If
End Sub
'*****************************************************
' Excel 2016対応：指定範囲を昇順で並び替える儀式
'*****************************************************
Sub SampleSort2016()
Dim ws As Worksheet
Dim SortRng As Range
Set ws = ActiveSheet
Set SortRng = ws.Range("A1:J11")
'◆ 並び替え対象シートを選択（2016では必須）
ws.Select
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Range("A1"), Order:=xlAscending
.SortFields.Add Key:=ws.Range("B1"), Order:=xlAscending
.SetRange SortRng
.Header = xlYes
.Apply
End With
Call exeBreak
End Sub
'*****************************************************
' Excel 365対応：指定範囲を昇順で並び替える儀式
'*****************************************************
Sub SampleSort365()
Dim ws As Worksheet
Dim SortRng As Range
Set ws = ActiveSheet
Set SortRng = ws.Range("A1:J11")
With ws.Sort
.SortFields.Clear
.SortFields.Add2 Key:=ws.Range("A1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=ws.Range("B1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange SortRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Call exeBreak
End Sub
'''*****************************************************
''' SortSample
'''*****************************************************
''Sub SampleSort()
'' Dim ws As Worksheet
'' Dim SortRng As Range
'' Set ws = ActiveSheet
'' 'ActiveSheet 以外､Select必須
'' With ws.Sort
'' '昇順に並び替え
'' With .SortFields
'' '既存情報をクリア
'' .Clear
'' .Add Key:=ws.Range("A1"), Order:=xlAscending
'' .Add Key:=ws.Range("B1"), Order:=xlAscending
'' End With
'' .SetRange ws.Range("A1:J11")
'' .Header = xlYes
'' .Apply
'' Call exeBreak
'' End With
''End Sub
'*****************************************************
' グレーの罫線
' Call MyLinestyleG(ShtName，上行、左列、下行、右列）
'*****************************************************
Function MyLineStyleG(shtName As String, LR As Long, _
lc As Long, RR As Long, RC As Long)
With ThisWorkbook.Worksheets(shtName)
With .Range(.Cells(LR, lc).Cells(RR, RC)).Borders
.LineStyle = xlContinuous
.ColorIndex = 16
.Weight = xlThin
End With
End With
End Function
'*****************************************************
' 黒の罫線
' Call MyLinestyle(ShtName，上行、左列、下行、右列）
'*****************************************************
Function MyLineStyle(shtName As String, LR As Long, _
lc As Long, RR As Long, RC As Long)
With ThisWorkbook.Worksheets(shtName)
With .Range(.Cells(LR, lc).Cells(RR, RC)).Borders
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThin
End With
End With
End Function
'*****************************************************
' グレーの罫線 外枠
' Call ThickLine(ShtName，上行、左列、下行、右列）
'*****************************************************
Function ThickLine(shtName As String, LR As Long, _
lc As Long, RR As Long, RC As Long)
With ThisWorkbook.Worksheets(shtName)
.Range(.Cells(LR, lc).Cells(RR, RC)).BorderAround _
LineStyle:=xlContinuous, _
Weight:=xlThick
End With
End Function
'*****************************************************
' 外枠 赤の点線
' Call RedDotLine(ShtName，上行、左列、下行、右列）
'*****************************************************
Function RedDotLine(shtName As String, LR As Long, _
lc As Long, RR As Long, RC As Long)
With ThisWorkbook.Worksheets(shtName)
.Range(.Cells(LR, lc).Cells(RR, RC)).BorderAround _
LineStyle:=xlDot, _
Weight:=xlThick, _
Color:=vbRed
End With
End Function
'*****************************************************
' 不要なリンクを一括削除
'*****************************************************
Sub CutLink()
Dim vntLink As Variant
Dim i As Long
vntLink = ThisWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(vntLink) Then
For i = 1 To UBound(vntLink)
ThisWorkbook.BreakLink Name:=vntLink(i), Type:=xlExcelLinks
Next i
End If
End Sub
'*****************************************************
' 不要なリンクを一括削除する完全版
' ・Excelリンク（外部ブック）を断つ
' ・名前定義に埋もれたリンクを削除
' ・グラフ系列に埋もれたリンクを解除
' ・クエリ接続を削除
'*****************************************************
Sub CutAllLink()
Dim vntLink As Variant
Dim i As Long
Dim nm As Name
Dim ws As Worksheet
Dim ch As ChartObject
Dim ser As Series
Dim qt As QueryTable
Dim lc As ListObject
'静かな準備
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'◆ Excelリンク（外部ブック）を断つ
vntLink = ThisWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(vntLink) Then
For i = 1 To UBound(vntLink)
ThisWorkbook.BreakLink Name:=vntLink(i), Type:=xlLinkTypeExcelLinks
Next i
End If
'◆ 名前定義に埋もれたリンクを削除
For Each nm In ThisWorkbook.Names
If InStr(1, nm.RefersTo, "[") > 0 Then
nm.Delete
End If
Next nm
'' '◆ グラフ系列に埋もれたリンクを解除（※ 通常はコメントアウト）
'' For Each ws In ThisWorkbook.Worksheets
'' For Each ch In ws.ChartObjects
'' For Each ser In ch.Chart.SeriesCollection
'' If InStr(1, ser.Formula, "[") > 0 Then
'' ser.Delete
'' End If
'' Next ser
'' Next ch
'' Next ws
''
'' '◆ クエリ接続を削除（QueryTable）（※ 通常はコメントアウト）
'' For Each ws In ThisWorkbook.Worksheets
'' For Each qt In ws.QueryTables
'' qt.Delete
'' Next qt
'' Next ws
''
'' '◆ クエリ接続を削除（ListObjectのQueryTable）（※ 通常はコメントアウト）
'' For Each ws In ThisWorkbook.Worksheets
'' For Each lc In ws.ListObjects
'' If lc.QueryTable Is Nothing Then
'' '何もしない
'' Else
'' lc.QueryTable.Delete
'' End If
'' Next lc
'' Next ws
'静かな後片付け
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "不要リンクの削除が完了しました。", vbInformation
End Sub
' +++*******************************************************+++
' アクティブシートのシェイプをすべて削除する儀式
' ・図形、テキストボックス、ボタンなどを対象
' ・静かに整え、再構築の余白をつくる
' +++*******************************************************+++
Public Sub delShapes()
Dim shp As Shape
'◆ もしシェイプが存在しない場合は、そっと終了
If ActiveSheet.Shapes.Count = 0 Then
'' MsgBox "このシートには削除対象のシェイプがありません。", vbInformation
Exit Sub
End If
'◆ シェイプをひとつずつ削除（静かに）
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
MsgBox "シェイプの削除が完了しました。", vbInformation
End Sub
'*****************************************************
' アクティブセルに色とサイズを設定する儀式
' ・背景色、文字色、罫線色・太さ
' ・列幅、行高の調整
'*****************************************************
Public Sub setRngBorders()
Dim lngBackColor As Long
Dim lngFontColor As Long
Dim lngBorderColor As Long
Dim intBorderWeight As Integer
Dim dblColumnWidth As Double
Dim dblRowHeight As Double
'◆ 色とサイズの定義（パステル調）
lngBackColor = 16506003 '背景色（淡いピンク）
lngFontColor = 16777215 '文字色（白）
lngBorderColor = 16506003 '罫線色（背景と同じ）
intBorderWeight = xlThin '罫線の太さ（細め）
dblColumnWidth = 65.2 '列幅
dblRowHeight = 24 '行高
With ActiveCell
'◆ 背景色と文字色
.Interior.Color = lngBackColor
.Font.Color = lngFontColor
'◆ 罫線（上下左右を個別に設定）
With .Borders(xlEdgeTop)
.Color = lngBorderColor
.Weight = intBorderWeight
End With
With .Borders(xlEdgeBottom)
.Color = lngBorderColor
.Weight = intBorderWeight
End With
With .Borders(xlEdgeLeft)
.Color = lngBorderColor
.Weight = intBorderWeight
End With
With .Borders(xlEdgeRight)
.Color = lngBorderColor
.Weight = intBorderWeight
End With
'◆ サイズ調整
.EntireColumn.ColumnWidth = dblColumnWidth
.EntireRow.RowHeight = dblRowHeight
End With
End Sub
'''+++*********************************************************+++
''' アクティブセル罫線 色、太さ
'''+++*********************************************************+++
''Public Sub setRngBorders()
'' Dim lng1 As Long
'' Dim lng2 As Long
'' Dim lng3 As Long
'' Dim Var4 As Variant
'' Dim dbl5 As Double
'' Dim dbl6 As Double
''
'' lng1 = 16506003
'' lng2 = 16777215
'' lng3 = 16506003
'' Var4 = 2
'' dbl5 = 65.2
'' dbl6 = 24
''
'' '"背景色"
'' ActiveCell.Interior.Color = lng1
'' '"文字色"
'' ActiveCell.Font.Color = lng2
'' '"罫線色"
'' ActiveCell.Borders.Color = lng3
'' '"罫線幅"
'' ActiveCell.Borders.Weight = Var4
'' '"列幅"
'' ActiveCell.EntireColumn.ColumnWidth = dbl5
'' '"行高"
'' ActiveCell.EntireRow.RowHeight = dbl6
''
''End Sub
'*****************************************************
' アクティブセルの列幅・行高を整える儀式
' ・列幅：65.2（ゆったりとした余白）
' ・行高：24（読みやすい高さ）
'*****************************************************
Public Sub setRngWH()
Dim dblColumnWidth As Double
Dim dblRowHeight As Double
'◆ サイズ定義
dblColumnWidth = 65.2
dblRowHeight = 24
With ActiveCell
'◆ 列幅の調整（横の余白を整える）
.EntireColumn.ColumnWidth = dblColumnWidth
'◆ 行高の調整（縦の呼吸を整える）
.EntireRow.RowHeight = dblRowHeight
End With
End Sub
'*******************************************************
' VBEの関数一覧取得
'*******************************************************
Sub ListProcedures()
Dim comp As Object
Dim line As String
Dim i As Long
Dim R As Long
R = 1
For Each comp In ThisWorkbook.VBProject.VBComponents
If comp.Type = 1 Then ' 標準モジュールのみ
Debug.Print "◆ " & comp.Name
For i = 1 To comp.CodeModule.CountOfLines
line = comp.CodeModule.Lines(i, 1)
If line Like "Public Function*" Or line Like "Sub*" Then
'Debug.Print line
ActiveSheet.Cells(R, 2).Value = line
R = R + 1
End If
Next i
End If
Next comp
End Sub
'*******************************************************
' シートタブの色設定
' 各シートに役割や雰囲気に応じた色を割り当てる
'*******************************************************
Sub SetBaseBookTabColors()
'一時的にエラー無視
On Error Resume Next
'一時的にエラー無視
With Sheets("Main")
.Tab.Color = 3680283 'ネイビー（基点）
End With
With Sheets("Ctrl")
.Tab.Color = 6299648 '濃紺（制御系）
End With
With Sheets("Ctrl1")
.Tab.Color = 6299648 '濃紺（制御系・補助）
End With
With Sheets("Data")
.Tab.Color = 15584675 'グレーイッシュブルー（データ領域）
End With
With Sheets("Work")
.Tab.Color = 9553021 '淡緑（作業用）
End With
With Sheets("Result")
.Tab.Color = 14396123 'パープルピンク（結果表示）
End With
With Sheets("クエリ")
.Tab.Color = 15721692 '淡グレー（外部連携）
End With
'エラーハンドリング解除
On Error GoTo 0
End Sub
'*******************************************************
' 指定列の空白セルを含む行を削除する静かな掃除
' 使用例：Call DelNullRowsInColumn(2) 'B列を対象
'*******************************************************
Sub DelNullRowsInColumn(colNum As Long)
Dim rng As Range
'=== 再計算なしで保存（高速）===
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
On Error Resume Next '空白がない場合のエラー回避
Set rng = ActiveSheet.Columns(colNum).SpecialCells(xlCellTypeBlanks)
'エラーハンドリング解除
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
End Sub
'*******************************************************
' 指定列の空白セルだけを上に詰める静かな整列
' 使用例：Call DelNullCellsInColumn(2) 'B列を対象
'*******************************************************
Sub DelNullCellsInColumn(colNum As Long)
Dim rng As Range
'一時的にエラー無視
On Error Resume Next
Set rng = ActiveSheet.Columns(colNum).SpecialCells(xlCellTypeBlanks)
'エラーハンドリング解除
On Error GoTo 0
If Not rng Is Nothing Then
rng.Delete Shift:=xlUp
End If
End Sub
'*******************************************************
' 空白行削除
' 下記コードの前に､
' Columns(2).Select 等 記載
'*******************************************************
Sub DelNullRows()
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
'*******************************************************
' 空白セル削除
' 下記コードの前に､
' Columns(2).Select 等 記載
'*******************************************************
Sub DelNullCells()
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
'*****************************************************
' アクティブセルの色とサイズ情報を取得する儀式
'*****************************************************
Public Sub GetRngColor()
Debug.Print "◆ 背景色：" & ActiveCell.Interior.Color
Debug.Print "◆ 文字色：" & ActiveCell.Font.Color
'◆ 罫線色と太さ（上下左右を個別に取得）
'' Debug.Print "◆ 罫線色（上）：" & ActiveCell.Borders(xlEdgeTop).Color
'' Debug.Print "◆ 罫線色（下）：" & ActiveCell.Borders(xlEdgeBottom).Color
'' Debug.Print "◆ 罫線色（左）：" & ActiveCell.Borders(xlEdgeLeft).Color
'' Debug.Print "◆ 罫線色（右）：" & ActiveCell.Borders(xlEdgeRight).Color
''
'' Debug.Print "◆ 罫線太さ（上）：" & ActiveCell.Borders(xlEdgeTop).Weight
'' Debug.Print "◆ 罫線太さ（下）：" & ActiveCell.Borders(xlEdgeBottom).Weight
'' Debug.Print "◆ 罫線太さ（左）：" & ActiveCell.Borders(xlEdgeLeft).Weight
'' Debug.Print "◆ 罫線太さ（右）：" & ActiveCell.Borders(xlEdgeRight).Weight
''
'' Debug.Print "◆ 列幅：" & ActiveCell.EntireColumn.ColumnWidth
'' Debug.Print "◆ 行高：" & ActiveCell.EntireRow.RowHeight
End Sub
'*****************************************************
' アクティブセルに色を設定する儀式
'*****************************************************
Public Sub SetRngColor()
Dim lngBackColor As Long
Dim lngFontColor As Long
'◆ 色定義（淡いピンクと白）
lngBackColor = 16506003 '背景色
lngFontColor = 16777215 '文字色
With ActiveCell
.Interior.Color = lngBackColor
.Font.Color = lngFontColor
End With
End Sub
コメント