LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@vide0man(ヨーケ)

便利なVBAマクロ

Posted at 

'***********************************************
' ハイパーリンクの設定処理
' シート名が入力されている選択状態のセルに対して、ハイパーリンクを設定します。
'***********************************************
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
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?