頻繁に使用する参照コード付き。クイックアクセスツールバーやリボンに登録して使用すると便利
(Microsoft365 64bit環境推奨)
G-Tool1-A01 からのつづき
6.【Alt】+【F11】キーを押下し、VBE画面を出す。
7.【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
8.下記ボックス内をコピーし、標準モジュールに貼り付ける。
9.モジュール名を【M01_Basic】に変更する。
モジュール名:M01_Basic
Option Explicit '+++*******************************************************+++ ' 列表示変更 '+++*******************************************************+++ Sub A_One_A() 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 End Sub '+++*******************************************************+++ ' マージ ' 選択セルを結合し、左寄せ、中央揃え、1文字インテンド '+++*******************************************************+++ Sub Merge() 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 End Sub '+++*******************************************************+++ ' アクティブセルの列を数値に変更 ' ※ タイトル行の下のセルを選択して実行する ' エラー値、大量データ対応Ver. '+++*******************************************************+++ Sub CvtToVal() Dim MaxRow As Long Dim R As Range Dim i As Long Dim x As Long Dim colNO As Long Dim myArray1 As Variant Dim myArray2 As Variant Dim sttRow As Long Dim endRow As Long Dim maxNo As Long Const PROsName = "CvtToVal" maxNo = 25000 Set R = ActiveCell sttRow = R.Row colNO = R.Column endRow = 0 With ActiveSheet MaxRow = .Cells(Rows.Count, R.Column).End(xlUp).Row If (MaxRow - sttRow) < maxNo Then x = 1 Else x = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0) End If For x = 1 To x If sttRow + maxNo > MaxRow Then endRow = MaxRow Else endRow = sttRow + maxNo End If myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) ReDim myArray2(LBound(myArray1) To UBound(myArray1)) '書式を数値に変更 .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)). _ NumberFormatLocal = "#0" For i = LBound(myArray1) To UBound(myArray1) If IsError(myArray1(i, 1)) Then myArray2(i) = myArray1(i, 1) ElseIf myArray1(i, 1) <> "" Then If IsNumeric(myArray1(i, 1)) Then myArray2(i) = Val(myArray1(i, 1)) Else myArray2(i) = myArray1(i, 1) End If Else myArray2(i) = "" End If Next i .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) = _ WorksheetFunction.Transpose(myArray2) Erase myArray1 Erase myArray2 sttRow = endRow + 1 Next x End With Erase myArray1 Erase myArray2 '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' アクティブセルの列を文字列に変更 ' ※ タイトル行の下のセルを選択して実行する。 ' エラー値、大量データ対応Ver. '+++*******************************************************+++ Sub CvtToStr() Dim MaxRow As Long Dim R As Range Dim i As Long Dim x As Long Dim colNO As Long Dim myArray1 As Variant Dim myArray2 As Variant Dim sttRow As Long Dim endRow As Long Dim maxNo As Long Const PROsName = "CvtToStr" maxNo = 25000 Set R = ActiveCell sttRow = R.Row colNO = R.Column endRow = 0 With ActiveSheet MaxRow = .Cells(Rows.Count, R.Column).End(xlUp).Row If (MaxRow - sttRow) < maxNo Then x = 1 Else x = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0) End If For x = 1 To x If sttRow + maxNo > MaxRow Then endRow = MaxRow Else endRow = sttRow + maxNo End If myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) ReDim myArray2(LBound(myArray1) To UBound(myArray1)) '書式を文字列に変更 .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)). _ NumberFormatLocal = "@" For i = LBound(myArray1) To UBound(myArray1) If IsError(myArray1(i, 1)) Then myArray2(i) = myArray1(i, 1) ElseIf myArray1(i, 1) <> "" Then myArray2(i) = CStr(myArray1(i, 1)) Else myArray2(i) = "" End If Next i .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) = _ WorksheetFunction.Transpose(myArray2) Erase myArray1 Erase myArray2 sttRow = endRow + 1 Next x End With Erase myArray1 Erase myArray2 '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' アクティブセルの列を短い日付に変更 ' ※ タイトル行の下のセルを選択して実行する。 ' エラー値、大量データ対応Ver. '+++*******************************************************+++ Sub CvtToDate() Dim MaxRow As Long Dim R As Range Dim i As Long Dim x As Long Dim colNO As Long Dim myArray1 As Variant Dim myArray2 As Variant Dim sttRow As Long Dim endRow As Long Dim maxNo As Long Const PROsName = "CvtToDate" maxNo = 25000 Set R = ActiveCell sttRow = R.Row colNO = R.Column endRow = 0 With ActiveSheet MaxRow = .Cells(Rows.Count, R.Column).End(xlUp).Row If (MaxRow - sttRow) < maxNo Then x = 1 Else x = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0) End If For x = 1 To x If sttRow + maxNo > MaxRow Then endRow = MaxRow Else endRow = sttRow + maxNo End If myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) ReDim myArray2(LBound(myArray1) To UBound(myArray1)) '書式を短い日付に変更 .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)). _ NumberFormatLocal = "yyyy/m/d" For i = LBound(myArray1) To UBound(myArray1) If IsError(myArray1(i, 1)) Then myArray2(i) = myArray1(i, 1) ElseIf myArray1(i, 1) <> "" Then If IsNumeric(myArray1(i, 1)) Then myArray2(i) = CDate(myArray1(i, 1)) Else myArray2(i) = myArray1(i, 1) End If Else myArray2(i) = "" End If Next i .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)) = _ WorksheetFunction.Transpose(myArray2) Erase myArray1 Erase myArray2 sttRow = endRow + 1 Next x End With Erase myArray1 Erase myArray2 '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' アクティブシートに100万件のNOを付け、 ’ 余分な右側を削除する書き方の例 '+++*******************************************************+++ Sub exeNumbering() Dim i As Long Dim MaxRow As Long '最終行 Dim MaxCol As Long '最終列 Dim PreSttNo As Long '開始番号を変更できる仕様 Dim noArray() As Variant With ActiveSheet 'B列基準最終行取得 MaxRow = .Cells(Rows.Count, 2).End(xlUp).Row PreSttNo = 1 - 1 '実際には.Cells(x,y).Value - 1 のように使用 ReDim noArray(100000, 0) For i = 0 To 100000 noArray(i, 0) = PreSttNo + i + 1 Next i .Range("A1") = "NO" .Range(.Cells(2, 1), .Cells(UBound(noArray) + 1, 1)) = noArray '1行目基準最終列取得 MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range(.Columns(MaxCol + 1), .Columns(MaxCol + 1).End(xlToRight)).Delete Shift:=xlToLeft End With End Sub '+++*******************************************************+++ ' 選択範囲列分の全角スペースを半角に統一 ' 飛び飛びの選択は対応させていない ' 1行目からシートの最終行まで '+++*******************************************************+++ Sub CvtToHarfSpace() Dim sltRng As Range Dim tgtRng As Range Dim sttCol As Long Dim endCol As Long Dim MaxRow As Long Const PROsName = "CvtToHarfSpace" With ActiveSheet '使用済み範囲の最終行、最終列 With .UsedRange MaxRow = .Rows(.Rows.Count).Row End With Set sltRng = Selection sttCol = sltRng.Column endCol = sttCol + sltRng.Columns.Count Set tgtRng = .Range(.Cells(1, sttCol), .Cells(MaxRow, endCol)) tgtRng.Replace " ", " ", xlPart End With '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' 選択範囲列分の半角スペースを全角に統一 ' 飛び飛びの選択は対応させていない ' 1行目からシートの最終行まで '+++*******************************************************+++ Sub CvtToHullSpace() Dim sltRng As Range Dim tgtRng As Range Dim sttCol As Long Dim endCol As Long Dim sttRow As Long Dim MaxRow As Long Const PROsName = "CvtToHullSpace" With ActiveSheet '使用済み範囲の最終行、最終列 With .UsedRange MaxRow = .Rows(.Rows.Count).Row End With Set sltRng = Selection sttCol = sltRng.Column endCol = sttCol + sltRng.Columns.Count Set tgtRng = .Range(.Cells(1, sttCol), .Cells(MaxRow, endCol)) tgtRng.Replace " ", " ", xlPart End With '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' アクティブシートの全セルをトリム '+++*******************************************************+++ Sub strTrim() Dim c As Range Const PROsName = "strTrim" Application.StatusBar = "トリム中~" 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 End Sub '+++*******************************************************+++ ' アクティブシートの図形を消去 '+++*******************************************************+++ Sub delShp() Dim shp As Shape Const PROsName = "strTrim" Application.StatusBar = "図を消去中~" 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 End Sub '+++*******************************************************+++ ' 目次シートを作成 '+++*******************************************************+++ Sub getSheetTitleList() Dim wsCont As Worksheet Dim i As Long Dim x As Long On Error GoTo getSheetTitleList_Err If IsCall = False Then Call StopUpdating End If ErrProsName = "getSheetTitleList" If IsSht("もくじ") = False Then Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = "もくじ" End If Set wsCont = Worksheets("もくじ") With wsCont .Columns(2).ClearContents .Range("B1").Value = ActiveWorkbook.Name .Range("B3").Value = "― もくじ ―" x = 5 For i = 1 To Sheets.Count If Worksheets(i).Name <> "もくじ" Then .Cells(x, 2) = Worksheets(i).Name '表示中シートのシート名だけ記入 If Worksheets(i).Visible Then .Cells(x, 2).Interior.Color = xlNone .Hyperlinks.Add anchor:=.Cells(x, 2), Address:="", _ SubAddress:="'" & Worksheets(i).Name & "'" & "!A1", _ TextToDisplay:=Worksheets(i).Name Else .Cells(x, 2).Interior.Color = rgbLightBlue End If End If .Cells(x, 2).Font.Color = vbBlue x = x + 1 Next i .Columns(2).EntireColumn.AutoFit .Select .Columns("A: A").ColumnWidth = 1.27 .Range("A1").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.Nuer & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName 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 End If 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 IsCall = False Then Call Updating '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If End Sub '+++*******************************************************+++ ' TitleSimple '+++*******************************************************+++ Public Sub TitleSimple() 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 '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If 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 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 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 '+++*******************************************************+++ ' 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 '+++*******************************************************+++ ' 全シートA1に画面スクロール '+++*******************************************************+++ Sub exeAllA1() Dim i As Long Call StopUpdating Call showStatus("セルA1 画面セット中") 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 Call Updating '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End Sub '+++*******************************************************+++ ' 最右シートに移動 '+++*******************************************************+++ Sub GotoLstSht() Dim i As Long 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 Call Updating '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If 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
コメント