MyRibbonTools F01_SQLCellStyler

Option Explicit
'+++*********************************************************+++
'    SQL用 文字色変更（予約語・コメント・文字列を色分け）
'+++*********************************************************+++
Public Sub ChangeColorSQL1()

    Dim rng As Range
    Dim cell As Range
    Dim str As String
    Dim pos1 As Long, pos2 As Long
    Dim startPos As Long, endPos As Long

    Dim keyword As Variant
    Dim keywordList As Variant
    Dim chk1 As Boolean, chk2 As Boolean

    '=== 予約語リスト（スペース入りは意図的）===
    keywordList = Array("SELECT", "FROM", "WHERE", "AND", "OR", "INSERT", "UPDATE", "DELETE", _
        "CREATE", "DISTINCT", "ALTER", "DROP", "TABLE", "VIEW", "INDEX", "JOIN", "LEFT", "RIGHT ", _
        "INNER ", "OUTER", "ON", "ORDER BY", "ASC", "DESC", "BETWEEN", "IN", "NOT", "NULL", " IS", _
        "LIKE", "CASE", "WHEN", "THEN", "ELSE", "END", "ESCAPE", "COUNT", "SUM", "AVG", "MAX", "MIN")

    Set rng = ActiveSheet.UsedRange

    For Each cell In rng
        If VarType(cell.Value) = vbString Then
            str = cell.Value

            '=== 予約語の色分け（青）===
            For Each keyword In keywordList
                startPos = InStr(1, UCase(str), UCase(keyword), vbBinaryCompare)
                Do While startPos > 0
                    endPos = startPos + Len(keyword) - 1
                    chk1 = False: chk2 = False

                    ' 前後の文字が区切りかどうか
                    Select Case True
                        Case startPos = 1
                            chk1 = True
                        Case Mid(str, startPos - 1, 1) Like "[ (]"
                            chk1 = True
                    End Select

                    If chk1 Then
                        Select Case True
                            Case endPos = Len(str)
                                chk2 = True
                            Case Mid(str, endPos + 1, 1) Like "[ )]"
                                chk2 = True
                        End Select
                    End If

                    If chk1 And chk2 Then
                        cell.Characters(startPos, Len(keyword)).Font.Color = vbBlue
                    End If

                    startPos = InStr(endPos + 1, UCase(str), UCase(keyword), vbBinaryCompare)
                Loop
            Next keyword

            '=== シングルクォーテーションで囲まれた文字列（濃い緑）===
            pos1 = InStr(1, str, "'")
            Do While pos1 > 0
                pos2 = InStr(pos1 + 1, str, "'")
                If pos2 > 0 Then
                    cell.Characters(pos1, pos2 - pos1 + 1).Font.Color = RGB(0, 100, 0)
                    pos1 = InStr(pos2 + 1, str, "'")
                Else
                    Exit Do
                End If
            Loop

            '=== コメント（-- で始まる行末まで／薄緑）===
            pos1 = InStr(1, str, "--")
            If pos1 > 0 Then
                cell.Characters(pos1, Len(str) - pos1 + 1).Font.Color = RGB(60, 179, 113)
            End If
        End If
    Next cell

    MsgBox "完了しました♪", vbInformation

    '=== 呼び出し元がない場合のみ儀式を実行 ===
    If IsCall = False Then
        Call Updating
        If ActiveWorkbook.Name <> ThisWorkbook.Name Then
            Windows(ThisWorkbook.Name).WindowState = xlMinimized
        End If
    End If

End Sub
'+++*********************************************************+++
'    SQL文分解：予約語で改行し、下のセルに展開
'+++*********************************************************+++
Sub SplitSQL()
    
    Dim rng As Range
    Dim rRow As Long
    Dim rCol As Long
    
    Dim sqlText As String
    Dim resultText As String
    Dim strCValue As String
    Dim dataArray As Variant
    Dim i As Long
    
    Dim deleteCharPlace As Long
    Dim keywordList As Variant
    Dim keyword As Variant

    ' 選択セルの取得
    Set rng = ActiveCell
    rRow = rng.Row
    rCol = rng.Column

    ' SQL文の取得
    sqlText = rng.Value

    ' 予約語リスト（スペース入りは意図的）
    keywordList = Array("SELECT", "FROM", "WHERE", "AND", "OR", "INSERT", "UPDATE", "DELETE", _
        "CREATE", "DISTINCT", "ALTER", "DROP", "TABLE", "VIEW", "INDEX", "JOIN", "LEFT", "RIGHT ", _
        "INNER ", "OUTER", "ON", "ORDER BY", "ASC", "DESC", "BETWEEN", "IN", "NOT", "NULL", " IS", _
        "LIKE", "CASE", "WHEN", "THEN", "ELSE", "END", "ESCAPE", "COUNT", "SUM", "AVG", "MAX", "MIN")

    ' SQL文を予約語で改行挿入
    resultText = sqlText
    For Each keyword In keywordList
        resultText = Replace(resultText, keyword, vbCrLf & keyword)
    Next keyword

    ' 改行で分割
    dataArray = Split(resultText, vbCrLf)

    With ActiveSheet
        ' 下の行に展開
        For i = 0 To UBound(dataArray)
            .Cells(rRow + 1 + i, rCol).Value = Trim(dataArray(i))
        Next i
    End With

    MsgBox "完了しました♪", vbInformation

    If IsCall = False Then
        Call Updating
        If ActiveWorkbook.Name <> ThisWorkbook.Name Then
            Windows(ThisWorkbook.Name).WindowState = xlMinimized
        End If
    End If

End Sub
'+++*********************************************************+++
'    改行コードで分解：セル内の改行を下方向に展開
'+++*********************************************************+++
Sub SplitCellByNewline()

    Dim rng As Range
    Dim rRow As Long, rCol As Long
    Dim dataArray As Variant
    Dim i As Long

    '=== 選択されたセルを取得 ===
    Set rng = ActiveCell
    rRow = rng.Row
    rCol = rng.Column

    '=== セル内の改行で分割 ===
    dataArray = Split(rng.Value, vbLf)

    With ActiveSheet
        '=== 下方向にセルを挿入（必要な行数分）===
        .Range(.Cells(rRow + 1, rCol), .Cells(rRow + UBound(dataArray), rCol)).Insert Shift:=xlDown

        '=== 分割した文字列を下のセルに展開 ===
        For i = LBound(dataArray) To UBound(dataArray)
            .Cells(rRow + i, rCol).Value = dataArray(i)
        Next i
    End With

    MsgBox "完了しました♪", vbInformation

    '=== 呼び出し元がない場合のみ儀式を実行 ===
    If IsCall = False Then
        Call Updating
        If ActiveWorkbook.Name <> ThisWorkbook.Name Then
            Windows(ThisWorkbook.Name).WindowState = xlMinimized
        End If
    End If

End Sub
'+++*********************************************************+++
'    選択行と上の行のドッキング（結合して上に吸収）
'+++*********************************************************+++
Sub strMerge()

    Dim rng As Range
    Dim rRow As Long, rCol As Long
    Dim strCValue As String, strUp As String

    With ActiveSheet
        '=== 選択されたセルを取得 ===
        Set rng = ActiveCell
        rRow = rng.Row
        rCol = rng.Column

        '=== 現在のセルと上のセルの値を取得 ===
        strCValue = rng.Value
        strUp = rng.Offset(-1, 0).Value

        '=== 上のセルに結合して書き込み ===
        rng.Offset(-1, 0).Value = strUp & strCValue

        '=== 現在のセルを削除（上に詰める）===
        rng.Delete Shift:=xlUp
    End With

    MsgBox "完了しました♪", vbInformation

    '=== 呼び出し元がない場合のみ儀式を実行 ===
    If IsCall = False Then
        Call Updating
        If ActiveWorkbook.Name <> ThisWorkbook.Name Then
            Windows(ThisWorkbook.Name).WindowState = xlMinimized
        End If
    End If

End Sub
'+++*********************************************************+++
'    改行コードを削除：vbCrLf / vbCr / vbLf をすべて除去
'+++*********************************************************+++
Sub RemoveLineBreaks()

    Dim cell As Range
    Dim strValue As String

    For Each cell In Selection
        '=== セルの値を取得 ===
        strValue = cell.Value

        '=== 改行コードをすべて削除 ===
        strValue = Replace(strValue, vbCrLf, "")
        strValue = Replace(strValue, vbCr, "")
        strValue = Replace(strValue, vbLf, "")

        '=== セルに書き戻し ===
        cell.Value = strValue
    Next cell

    MsgBox "完了しました♪", vbInformation

    '=== 呼び出し元がない場合のみ儀式を実行 ===
    If IsCall = False Then
        Call Updating
        If ActiveWorkbook.Name <> ThisWorkbook.Name Then
            Windows(ThisWorkbook.Name).WindowState = xlMinimized
        End If
    End If

End Sub