〇〇さんの部屋

Sub テストSQL作成()
Dim folderPath As String
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim fileNameWithoutExt As String
Dim newFileName As String
Dim i As Integer

'フォルダパスの設定
folderPath = "c:\test\"

'FileSystemObjectの作成
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

'フォルダ内のすべての.txtファイルをループ
For Each file In folder.Files
    If fso.GetExtensionName(file.Name) = "txt" Then
        'ファイル名から拡張子を取り除く
        fileNameWithoutExt = Left(file.Name, Len(file.Name) - Len(fso.GetExtensionName(file.Name)) - 1)

        'コピーを3つ作成
        For i = 1 To 1
            newFileName = folderPath & fileNameWithoutExt & "_" & Format(i, "00") & ".sql"
            fso.CopyFile file.Path, newFileName
        Next i
    End If
Next file

End Sub

Sub 完成版From句複数星コメントをハイフンに_From句だけ抽出()
Dim folderPath As String
Dim fileName As String
Dim fileLine As String
Dim outputFilePath As String
Dim outputFile As Object
Dim fso As Object
Dim textFile As Object
Dim inCommentBlock As Boolean
Dim cleanLine As String
Dim lineNumber As Long
Dim finalContent As String
Dim inFromClause As Boolean
Dim concatenatedLine As String
Dim endPos As Long
Dim keywordPos As Long

'フォルダパスの設定
folderPath = "c:\test\"

'FileSystemObjectの作成
Set fso = CreateObject("Scripting.FileSystemObject")
finalContent = ""

'フォルダ内のファイルをループ
fileName = Dir(folderPath & "*.sql")
Do While fileName <> ""
    'ファイルの内容を読み込む
    Set textFile = fso.OpenTextFile(folderPath & fileName, 1)
    inCommentBlock = False
    lineNumber = 0
    inFromClause = False
    concatenatedLine = ""

    Do While Not textFile.AtEndOfStream
        lineNumber = lineNumber + 1
        fileLine = textFile.ReadLine
        cleanLine = " " & Replace(fileLine, vbTab, " ")
        cleanLine = Replace(cleanLine, "  ", " ")

        '星コメントを--コメントに変換
        If InStr(cleanLine, "/*") > 0 Then
            inCommentBlock = True
        End If
        If inCommentBlock Then
            cleanLine = "-- " & cleanLine
            If InStr(cleanLine, "*/") > 0 Then
                inCommentBlock = False
            End If
        End If

        'FROM句を含む行を検出
        If InStr(1, cleanLine, " FROM ", vbTextCompare) > 0 Then
            inFromClause = True
            concatenatedLine = fileName & "(" & lineNumber & "):" & Trim(cleanLine)
        ElseIf inFromClause Then
            '連結するテーブル名を抽出
            concatenatedLine = concatenatedLine & " " & Trim(cleanLine)
        End If

        'WHERE、GROUP BY、ORDER BY、HAVING 句以降を無視
        If inFromClause And (InStr(1, cleanLine, " WHERE ", vbTextCompare) > 0 Or _
                             InStr(1, cleanLine, " GROUP BY ", vbTextCompare) > 0 Or _
                             InStr(1, cleanLine, " ORDER BY ", vbTextCompare) > 0 Or _
                             InStr(1, cleanLine, " HAVING ", vbTextCompare) > 0 Or _
                             InStr(1, cleanLine, ";", vbTextCompare) > 0) Then
            inFromClause = False
            '終了位置を決定して句を切り取る
            keywordPos = InStr(1, concatenatedLine, " FROM ", vbTextCompare)
            endPos = InStr(keywordPos + 5, concatenatedLine, " WHERE ", vbTextCompare)
            If endPos = 0 Then endPos = InStr(keywordPos + 5, concatenatedLine, " GROUP BY ", vbTextCompare)
            If endPos = 0 Then endPos = InStr(keywordPos + 5, concatenatedLine, " ORDER BY ", vbTextCompare)
            If endPos = 0 Then endPos = InStr(keywordPos + 5, concatenatedLine, " HAVING ", vbTextCompare)
            If endPos = 0 Then endPos = InStr(keywordPos + 5, concatenatedLine, ";", vbTextCompare)
            If endPos > 0 Then
                concatenatedLine = Left(concatenatedLine, endPos - 1)
            End If
            finalContent = finalContent & concatenatedLine & vbCrLf
            concatenatedLine = ""
        End If
    Loop

    textFile.Close
    fileName = Dir
Loop

'結果を一つのファイルに書き込む（出力先をc:\test2に変更）
outputFilePath = "c:\test2\From抽出.txt"
Set outputFile = fso.CreateTextFile(outputFilePath, True)
outputFile.WriteLine finalContent
outputFile.Close

End Sub

Sub テキストボックスに書き込み()
Dim shp As Shape
Dim i As Integer
Dim lastRow As Long
Dim firstLine As String
Dim secondLine As String
Dim pos As Long

' シート内の最後の行を取得
lastRow = ActiveSheet.Cells(rows.Count, "K").End(xlUp).Row

' 空のテキストボックスに値を埋める
i = 1
For Each shp In ActiveSheet.Shapes
    If shp.Type = msoTextBox Then
        If shp.TextFrame.Characters.Text = "" Then
            If i <= lastRow Then
                ' 1行目と2行目の内容を設定
                firstLine = Cells(i, "L").Value
                secondLine = Cells(i, "M").Value
                shp.TextFrame.Characters.Text = firstLine & vbCrLf & secondLine

                ' 1行目のフォント設定
                With shp.TextFrame.Characters(1, Len(firstLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 11
                End With

                ' 2行目のフォント設定
                pos = Len(firstLine) + 2 ' 2行目の開始位置を設定
                With shp.TextFrame.Characters(pos, Len(secondLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 8
                End With

                ' テキストを中央揃えに設定
                shp.TextFrame.HorizontalAlignment = xlHAlignCenter

                i = i + 1
            Else
                Exit For
            End If
        End If
    End If
Next shp

End Sub
Sub テキストボックスを作成()
Dim originalShape As Shape
Dim newShape As Shape
Dim i As Integer, j As Integer
Dim horizontalSpacing As Single
Dim verticalSpacing As Single
Dim rows As Integer
Dim columns As Integer

' 行と列の数を入力するためのInputBoxを表示
rows = InputBox("何行にしますか？", "行の設定", 3)
columns = InputBox("何列にしますか？", "列の設定", 3)

' 新しいテキストボックスを作成
Set originalShape = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 50)
With originalShape.TextFrame.Characters.Font
    .Name = "Meiryo UI"
    .Size = 11 ' 任意の初期サイズ
End With
' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
With originalShape.line
    .ForeColor.RGB = RGB(0, 0, 0)
    .Weight = 0.75
End With
originalShape.Fill.Transparency = 1

' 間隔の設定
horizontalSpacing = 20
verticalSpacing = 10

' 指定された行と列で複製
For j = 0 To rows - 1
    For i = 0 To columns - 1
        If i > 0 Or j > 0 Then
            ' 複製を作成
            Set newShape = originalShape.Duplicate
            ' 新しい位置を設定
            newShape.Left = originalShape.Left + (originalShape.Width + horizontalSpacing) * i
            newShape.Top = originalShape.Top + (originalShape.Height + verticalSpacing) * j
            ' デフォルトのフォントを設定
            With newShape.TextFrame.Characters.Font
                .Name = "Meiryo UI"
                .Size = 11 ' 任意の初期サイズ
            End With
            ' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
            With newShape.line
                .ForeColor.RGB = RGB(0, 0, 0)
                .Weight = 0.75
            End With
            newShape.Fill.Transparency = 1
        End If
    Next i
Next j

End Sub

Sub フローチャートシェイプを作成()
Dim originalShape As Shape
Dim newShape As Shape
Dim i As Integer, j As Integer
Dim horizontalSpacing As Single
Dim verticalSpacing As Single
Dim rows As Integer
Dim columns As Integer

' 行と列の数を入力するためのInputBoxを表示
rows = InputBox("何行にしますか？", "行の設定", 3)
columns = InputBox("何列にしますか？", "列の設定", 3)

' 新しいフローチャートの「データ」シェイプを作成
Set originalShape = ActiveSheet.Shapes.AddShape(msoShapeFlowchartDocument, 100, 100, 100, 50)
With originalShape.TextFrame.Characters.Font
    .Name = "Meiryo UI"
    .Size = 11 ' 任意の初期サイズ
    .Color = RGB(0, 0, 0) ' テキストの色を黒に設定
End With

' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
With originalShape.line
    .ForeColor.RGB = RGB(0, 0, 0)
    .Weight = 0.75
End With
originalShape.Fill.Transparency = 1

' 間隔の設定
horizontalSpacing = 20
verticalSpacing = 10

' 指定された行と列で複製
For j = 0 To rows - 1
    For i = 0 To columns - 1
        If i > 0 Or j > 0 Then
            ' 複製を作成
            Set newShape = originalShape.Duplicate
            ' 新しい位置を設定
            newShape.Left = originalShape.Left + (originalShape.Width + horizontalSpacing) * i
            newShape.Top = originalShape.Top + (originalShape.Height + verticalSpacing) * j
            ' デフォルトのフォントとテキストの色を設定
            With newShape.TextFrame.Characters.Font
                .Name = "Meiryo UI"
                .Size = 11 ' 任意の初期サイズ
                .Color = RGB(0, 0, 0) ' テキストの色を黒に設定
            End With
            ' 塗りつぶしなし、線の色は黒、線の太さは0.75に設定
            With newShape.line
                .ForeColor.RGB = RGB(0, 0, 0)
                .Weight = 0.75
            End With
            newShape.Fill.Transparency = 1
        End If
    Next i
Next j

End Sub

Sub フローチャートシェイプにテキスト書き込み()
Dim shp As Shape
Dim i As Integer
Dim lastRow As Long
Dim firstLine As String
Dim secondLine As String
Dim pos As Long

' シート内の最後の行を取得
lastRow = ActiveSheet.Cells(rows.Count, "K").End(xlUp).Row

' 空のフローチャートシェイプに値を埋める
i = 1
For Each shp In ActiveSheet.Shapes
    ' シェイプの名前に "Document" が含まれている場合
    If shp.Name Like "*Document*" Then
        If shp.TextFrame.Characters.Text = "" Then
            If i <= lastRow Then
                ' 1行目と2行目の内容を設定
                firstLine = Cells(i, "L").Value
                secondLine = Cells(i, "M").Value
                shp.TextFrame.Characters.Text = firstLine & vbCrLf & secondLine

                ' 1行目のフォント設定
                With shp.TextFrame.Characters(1, Len(firstLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 11
                    .Color = RGB(0, 0, 0) ' 文字色を黒に設定
                End With

                ' 2行目のフォント設定
                pos = Len(firstLine) + 2 ' 2行目の開始位置を設定
                With shp.TextFrame.Characters(pos, Len(secondLine)).Font
                    .Name = "Meiryo UI"
                    .Size = 8
                    .Color = RGB(0, 0, 0) ' 文字色を黒に設定
                End With

                ' テキストを中央揃えに設定
                shp.TextFrame.HorizontalAlignment = xlHAlignCenter

                i = i + 1
            Else
                Exit For
            End If
        End If
    End If
Next shp

End Sub

2024.10.30

Sub シェイプ名を設定()
Dim shp As Shape
Dim ws As Worksheet

' アクティブシートを設定
Set ws = ActiveSheet

' シート内の全てのシェイプをループ
For Each shp In ws.Shapes
    If shp.TextFrame2.HasText Then
        ' シェイプの名前をテキストに変更
        shp.Name = shp.TextFrame2.TextRange.Text
    End If
Next shp

End Sub

2024.10.30

Sub シェイプ内を検索()
Dim shp As Shape
Dim ws As Worksheet
Dim resultWs As Worksheet
Dim keyword As String
Dim found As Boolean
Dim resultRow As Long
Dim shapeFullName As String
Dim wb As Workbook

' キーワードをInputBoxで入力
keyword = InputBox("検索したいキーワードを入力してください:")

' 検索結果が見つかったかどうかのフラグ
found = False

' アクティブブックを設定
Set wb = ActiveWorkbook

' 検索結果ワークシートを作成
On Error Resume Next
Set resultWs = wb.Sheets("検索結果")
On Error GoTo 0

If resultWs Is Nothing Then
    Set resultWs = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    resultWs.Name = "検索結果"
Else
    resultWs.Cells.Clear
End If

resultRow = 1

' アクティブシートを設定
Set ws = ActiveSheet

' シート内の全てのシェイプをループ
For Each shp In ws.Shapes
    If shp.TextFrame2.HasText Then
        ' シェイプのテキストを取得し、キーワードを検索
        If InStr(1, shp.TextFrame2.TextRange.Text, keyword, vbTextCompare) > 0 Then
            ' シェイプを選択
            shp.Select Replace:=False
            ' シェイプ名を「ブック名-シート名-シェイプ名」の形式に（シート名とシェイプ名のアンダーバーをハイフンに変更）
            shapeFullName = wb.Name & "-" & Replace(ws.Name & "-" & shp.Name, "_", "-")
            ' 結果ワークシートに記述
            resultWs.Cells(resultRow, 1).Value = shapeFullName
            resultRow = resultRow + 1
            found = True
        End If
    End If
Next shp

' キーワードが見つかったかどうかを知らせる
If found Then
    MsgBox "キーワード '" & keyword & "' が見つかりました。検索結果シートを確認してください。"
Else
    MsgBox "キーワード '" & keyword & "' は見つかりませんでした。"
End If

End Sub

2024.10.31

Sub フローチャートシェイプにテキスト書き込み_フォントOK()
Dim shape As shape
Set shape = ActiveSheet.Shapes(“DOC1”) ‘ ここで “YourShapeNameHere” を実際のシェイプ名に置き換えます

With shape.TextFrame2.TextRange
    .Text = "〇〇〇〇〇〇〇〇" & Chr(13) & "△△△△△△△△" & Chr(13) & "斎藤さん"

    Dim charRanges As Variant
    charRanges = Array(Array(1, 8), Array(9, 1), Array(10, 8), Array(18, 1), Array(19, 4))

    Dim i As Integer
    For i = LBound(charRanges) To UBound(charRanges)
        With .Characters(charRanges(i)(0), charRanges(i)(1)).Font
            .NameComplexScript = "+mn-cs"
            .NameFarEast = "Meiryo UI"
            .Fill.Visible = msoTrue
            .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
            .Fill.ForeColor.TintAndShade = 0
            .Fill.ForeColor.Brightness = 0
            .Fill.Transparency = 0
            .Fill.Solid
            .Size = 11
            .Name = "Meiryo UI"
        End With
    Next i

    ' 文字サイズの設定
    .Characters(10, 9).Font.Size = 8
    .Characters(19, 4).Font.Size = 14

    ' 段落の設定
    .Characters(1, 9).ParagraphFormat.FirstLineIndent = 0
    .Characters(1, 9).ParagraphFormat.Alignment = msoAlignLeft
    .Characters(10, 9).ParagraphFormat.FirstLineIndent = 0
    .Characters(10, 9).ParagraphFormat.Alignment = msoAlignLeft
    .Characters(19, 4).ParagraphFormat.FirstLineIndent = 0
    .Characters(19, 4).ParagraphFormat.Alignment = msoAlignLeft
End With

End Sub

Sub シェイプ名を取得()
Dim shape As shape
For Each shape In ActiveSheet.Shapes
Debug.Print shape.Name
Next shape
End Sub

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル