便利なVBAマクロ

```vb

'***********************************************
' ハイパーリンクの設定処理
' シート名が入力されている選択状態のセルに対して、ハイパーリンクを設定します。
'***********************************************
Public Sub ハイパーリンクの設定()

    For Each curCell In Selection

        Dim sheetName As String: sheetName = curCell.Value

        ' シートが存在する場合、ハイパーリンクを設定します
        If ExistsWorksheet(ActiveWorkbook, sheetName) Then

            ActiveSheet.Hyperlinks.Add Anchor:=curCell, Address:="", SubAddress:="' & sheetName & '!A1", TextToDisplay:=sheetName

        End If

    Next

End Sub

'***********************************************
' Excelファイルの仕上げ処理
' 1. すべてのシートに対して以下の処理を行います。
' 2. 1行2列を選択状態にする
' 3. 表示倍率を100%
' 4. 表示枠線を非表示にする
' 5. 2番目のシートを表示状態にする
'***********************************************
Public Sub Excelファイルの仕上げ()

    On Error Resume Next

    ' 画面更新の停止
    Application.ScreenUpdating = False

    ' シートカウント変数
    Dim i As Integer
    For i = 1 To Worksheets.Count

        ' ワークシートをアクティブ化
        Worksheets(i).Activate

        ' 左上にスクロール
        Dim j As Integer
        For j = 1 To Windows(i).Panes.Count
            Windows(i).Panes(j).ScrollColumn = 1
            Windows(i).Panes(j).ScrollRow = 1
        Next

        ' 左上を選択
        ActiveSheet.Cells(1, 1).Select

        ' 枠線非表示
        ActiveWindow.DisplayGridlines = False

        ' 倍率100%
        ActiveWindow.Zoom = 100

    Next

    ' 2番目のシートをアクティブ化
    Worksheets(1).Activate

    ' 画面更新の再開
    Application.ScreenUpdating = True

End Sub

'***********************************************
' セル内改行を<br>タグに置換
'***********************************************
Public Sub セル内改行をタグに置換()
    ActiveSheet.UsedRange.Replace What:=vbLf, Replacement:="<br>", LookAt:=xlPart
End Sub

'***********************************************
' <br>タグをセル内改行に置換
'***********************************************
Public Sub タグをセル内改行に置換()
    ActiveSheet.UsedRange.Replace What:="<br>", Replacement:=vbLf, LookAt:=xlPart
End Sub

'***********************************************
' 上のセルと値が同じ場合に罫線上マークに置換
'***********************************************
Public Sub 上のセルと値が同じ場合に罫線上マークに置換()
    Dim i As Long
    With Selection
        For i = .Count To 1 Step -1
            If .Item(i).Value <> "" Then
                ' 1つ上のセルと比較
                If .Item(i).Value = .Item(i).Offset(-1, 0).Value Then
                    .Item(i).Value = ""
                End If
            End If
        Next i
    End With
End Sub

'***********************************************
' 罫線上マークを上のセルと値に置換
'***********************************************
Public Sub 罫線上マークを上のセルと値に置換()
    For Each curCell In Selection
        If curCell.Value = "" Then
            curCell.Value = curCell.Offset(-1, 0).Value
        End If
    Next
End Sub

' クリップボードにコピー
' 選択範囲のセルの値をクリップボードにコピーします
Public Sub クリップボードにコピー()
    Dim buf As String, CB As New DataObject

    For Each rCell In Selection
        buf = buf & rCell.Value & vbCrLf
    Next

    With CB
        .SetText buf
        .PutInClipboard ' 変数のオブジェクト型変数
    End With
End Sub

' 罫線の色変更
' 選択範囲の罫線の色を変更します
Public Sub 罫線の色変更()
    Dim c As Range
    Dim i As Integer

    ' 画面更新の停止
    Application.ScreenUpdating = False

    For Each c In Selection
        For i = 7 To 10
            If c.Borders(i).LineStyle <> xlNone Then
                c.Borders(i).ColorIndex = 16
            End If
        Next i
    Next c

    ' 画面更新の再開
    Application.ScreenUpdating = True
End Sub

' 色変更
' 選択セルの2～4列のセルからRGB値を取得して背景色を変更します
Public Sub 色変更()
    Dim c As Range

    ' 画面更新の停止
    Application.ScreenUpdating = False

    For Each c In Selection
        c.Interior.Color = RGB(c.Offset(0, 2).Value, c.Offset(0, 3).Value, c.Offset(0, 4).Value)
    Next c

    ' 画面更新の再開
    Application.ScreenUpdating = True
End Sub

End If
End Function

Public Sub on_f2()
    SendKeys ("{F2}")
End Sub

'***************************************************************
'選択されているセルの全角英数字を半角英数字に変換
'***************************************************************
Public Sub 全角英数字に変換()
    Dim cell As Range
    Dim selectedRange As Range
    Dim fullWidthChars As String
    Dim halfWidthChars As String
    Dim i As Integer
    Dim newText As String

    '全角英数字と半角英数字
    fullWidthChars = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ０１２３４５６７８９"
    halfWidthChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

    '選択範囲を取得
    Set selectedRange = Selection

    '選択範囲の各セルを処理
    For Each cell In selectedRange
        If Not IsEmpty(cell) Then
            newText = cell.Value
            '全角英数字を半角英数字に変換
            For i = 1 To Len(fullWidthChars)
                newText = Replace(newText, Mid(fullWidthChars, i, 1), Mid(halfWidthChars, i, 1))
            Next i
            cell.Value = newText
        End If
    Next cell
End Sub

'***************************************************************
'選択されているセルの値をそのまま設定
'***************************************************************
Public Sub 値をそのまま設定()
    Dim cell As Range
    Dim selectedRange As Range

    '選択範囲を取得
    Set selectedRange = Selection

    '選択範囲の各セルを処理
    For Each cell In selectedRange
        cell.Value = cell.Value
    Next cell
End Sub

'**********************************************************************
'選択されているセルの関数を値に変換する
'**********************************************************************
Public Sub 選択されているセルの関数を値に変換()

    '選択範囲を取得
    Set selectedRange = Selection

    '選択範囲内の各セルを処理
    For Each cell In selectedRange
        cell.Value = cell.Value
    Next cell

End Sub

'**********************************************************************
'選択されているセルにTRUE/FALSEの条件付き書式を設定する
'**********************************************************************
Public Sub 選択されているセルにTRUE/FALSEの条件付き書式を設定する()

    Dim rng As Range
    Dim cell As Range

    '選択範囲を取得
    Set rng = Selection

    '選択範囲の各セルに対して条件付き書式を設定
    For Each cell In rng
        With cell.FormatConditions
            '既存の条件付き書式をクリア
            .Delete

            'TRUEの場合の条件付き書式を追加
            .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="TRUE"
            .Item(1).Interior.Color = RGB(200, 255, 200)

            'FALSEの場合の条件付き書式を追加
            .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="FALSE"
            .Item(2).Interior.Color = RGB(255, 200, 200)
        End With
    Next cell

End Sub

' シートが存在するかの判定処理
' 指定されたworkbookに、指定されたシート名のシートが存在するか判定します
' ***********************************************
Public Function ExistsWorksheet(Workbook As Workbook, sheetName As String)

    Dim tempWorksheet As Worksheet

    On Error Resume Next
    Set tempWorksheet = Workbook.Worksheets(sheetName)
    On Error GoTo 0

    ExistsWorksheet = Not tempWorksheet Is Nothing

End Function

' ***********************************************
' TEXTJOIN
' ***********************************************
Public Function TEXTJOIN(Delim, Ignore As Boolean, ParamArray par())

    Dim i As Integer
    Dim tR As Range

    TEXTJOIN = ""
    For i = LBound(par) To UBound(par)
        If TypeName(par(i)) = "Range" Then
            For Each tR In par(i)

                If tR.Value <> "" Or Ignore = False Then
                    TEXTJOIN = TEXTJOIN & Delim & tR.Value2
                End If

            Next
        Else
            If par(i) <> "" Or Ignore = False Then
                TEXTJOIN = TEXTJOIN & Delim & par(i)
            End If
        End If
    Next
    TEXTJOIN = Mid(TEXTJOIN, Len(Delim) + 1)

End Function

' ***********************************************
' XLOOKUP
' ***********************************************
Function XLOOKUP(検索値, 検索範囲, 戻り値の配列)
    ct_search = 0
    For Each value_search In 検索範囲
        If 検索値 = value_search Then
            Exit For
        End If
        ct_search = ct_search + 1
    Next
    ct_return = 0
    For Each value_return In 戻り値の配列
        If ct_search = ct_return Then
            Exit For
        End If
        ct_return = ct_return + 1
    Next
    XLOOKUP = value_return
End Function

' ***********************************************
' 範囲の最後の値を取得
' ***********************************************
Public Function LastCell(ParamArray par())

    For i = LBound(par) To UBound(par)
        If TypeName(par(i)) = "Range" Then
            For Each tR In par(i)
                If tR.Value <> "" Then
                    LastCell = tR
                End If
            Next
        Else
            If par(i) <> "" Then
                LastCell = tR
            End If
        End If
    Next

End Function

```