Template_M01_Basic

2023.09.19

頻繁に使用する参照コード付き。クイックアクセスツールバーやリボンに登録して使用すると便利
（Microsoft365 64bit環境推奨）

　G-Tool1-A01 からのつづき
　６．【Alt】＋【F11】キーを押下し、VBE画面を出す。
　７．【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
　８．下記ボックス内をコピーし、標準モジュールに貼り付ける。
　９．モジュール名を【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
'+++*******************************************************+++
'   　連番の記入　数値、日にち
'+++*******************************************************+++
Sub exeSerialNo()
    With ActiveSheet
        .Cells(1, 1).Select
        '初期値を入力
    '    ActiveCell.FormulaR1C1 = "1"
        '横方向に1000まで連番記入
    '    .Cells(1, 1).DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, Step _
            :=1, Stop:=1000, Trend:=False
        '縦方向に1000まで連番記入
    '    .Cells(1, 1).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
            Step:=1, Stop:=30000, Trend:=False
        .Cells(1, 1).FormulaR1C1 = "11/22/2023"
        '日付
        .Cells(1, 1).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
           xlDay, Step:=1, Stop:=#12/31/2023#, Trend:=False
    End With
End Sub
Sub useEx()
    Call assignSerialNo("I5", 1000)
End Sub
'+++*******************************************************+++
'   　連番の記入
'     引数１：スタートレンジ
'     引数２：連続数
'     Call assignSerialNo("I5", 1000)
'+++*******************************************************+++
Sub assignSerialNo(strRng As String, srlNo As Long)
    With Range(strRng)
        .Value = "1"
        .AutoFill .Resize(srlNo), xlFillSeries
    End With
End Sub
'+++*******************************************************+++
'   　連番の記入
'+++*******************************************************+++
Sub asgnSerialNo()
    With Range("F5")
'        .Value = "A-101"
        .Value = "1"
        .AutoFill .Resize(30000), xlFillSeries
    End With
End Sub
'+++*******************************************************+++
'   　連続した日にちの記入
'+++*******************************************************+++
Sub asgnSerialDate()
'    '日にちが増える
'    With Range("F5")
'        .Value = "2021/4/1"
'        .AutoFill .Resize(5), xlFillSeries
'    End With
    '"月"を連続データの対象にします
    With Range("G5")
        .Value = "2021/4/1"
        .AutoFill .Resize(5), xlFillMonths
    End With
    '"年"を連続データの対象にします
    With Range("H5")
        .Value = "2021/4/1"
        .AutoFill .Resize(5), xlFillYears
    End With
End Sub

コメント

タイトルとURLをコピーしました