SharePoint上のフォルダ容量を確認するには、記憶域メトリックスの機能を利用するのが便利です。以下の手順で確認できます：

1. サイト管理者のアカウントで、該当のSharePointサイトにアクセスします。
2. サイトのホームページ右上にある歯車アイコンをクリックし、サイト情報 → すべてのサイト設定を表示を選択します。
3. サイトコレクションの管理の項目内にある記憶域メトリックスをクリックします。
4. サイト内のドキュメントライブラリの合計サイズやフォルダ単位の容量を確認できます。

また、Excelにエクスポートすることで、フォルダとファイルの一覧を取得し、詳細な分析を行うことも可能です。

Windows への PowerShell のインストール – PowerShell | Microsoft Learn

SharePoint Technical Notes : PnP PowerShell の概要とインストール

【pnpPowerShellのインストール、バージョン表示（pnpPowerShellコマンド）】

Install-Module PnP.PowerShell -Scope CurrentUser -Force

(Get-InstalledModule -Name PnP.PowerShell -AllVersions).Version

(参考）１回　https://www.qes.co.jp/media/microsoft/SharePoint/a481

　　　 2回　https://www.qes.co.jp/media/microsoft/SharePoint/a520

GoFileTop(0); // ファイルの先頭に移動
SelectLine(0);//行選択
Delete(0); // 削除

//キーボードマクロのファイル
ReplaceAll(‘します’, ”, 28); // すべて置換
ReDraw(0); // 再描画

ReplaceAll(‘:’, ‘＞’, 24); // すべて置換
ReDraw(0); // 再描画

CurLineCenter(0); // カーソル行をウィンドウ中央へ
ReplaceAll(‘^(.*)＞’, ‘＜\1＞’, 28); // すべて置換
ReDraw(0); // 再描画

ReplaceAll(‘^([^＜]*)$’, ‘・\1’, 28); // すべて置換
ReDraw(0); // 再描画

ReplaceAll(‘^＜’, ‘\r\n＜’, 28); // すべて置換
ReDraw(0); // 再描画
ReplaceAll(‘\r\n・’, ‘・’, 28); // すべて置換
ReDraw(0); // 再描画

Dim HyperlinkStack As Collection ‘マクロ外で設定
Dim ShapeAddressStack As Collection

Sub InitializeHyperlinkStack()
Set HyperlinkStack = New Collection
Set ShapeAddressStack = New Collection
End Sub

Sub StoreHyperlink() ‘飛んでくる元のボタンに登録するマクロ
If HyperlinkStack Is Nothing Then InitializeHyperlinkStack

Dim foundCell As Range
Dim searchString As String
searchString = "AAA()" ' 検索したい文字列を設定

' シート内を検索
Set foundCell = ActiveSheet.Cells.Find(What:=searchString, LookAt:=xlPart, MatchCase:=False)

' 見つかった場合、アドレスをスタックに追加してジャンプ
If Not foundCell Is Nothing Then
    ShapeAddressStack.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address
    foundCell.Select
Else
    MsgBox "指定された文字列が見つかりません。"
End If

End Sub

Sub HyperlinkBack() ‘戻るボタンに登録するマクロ
On Error GoTo ErrHandler
If ShapeAddressStack.Count > 0 Then
Range(ShapeAddressStack(ShapeAddressStack.Count)).Select
ShapeAddressStack.Remove ShapeAddressStack.Count
Else
MsgBox “元の図形の場所に戻ることができません。”
End If
Exit Sub
ErrHandler:
MsgBox “元の図形の場所に戻ることができません。”
End Sub

★指定したフォルダ内のブックにおいて、現在開いているアクティブシートのA列にまとめたい新規のブック名（拡張子付き）を登録、Ｂ列にそのブックにもっていきたい（そのフォルダ内の）ブック名（拡張子付き）を登録しておく★

Sub 指定ブックをシートに登録()
Dim folderPath As String
Dim fileName As String
Dim sheetName As String
Dim targetWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim cell As Range
Dim ws As Worksheet
Dim totalFiles As Long
Dim processedFiles As Long

' フォルダのパスを入力
folderPath = InputBox("操作対象になるフォルダのパスを入力してください", "フォルダの選択")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

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

' 処理対象のファイル数をカウント
totalFiles = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row).Count
processedFiles = 0

' A列の各セルをループ
For Each cell In ActiveSheet.Range("A1:A" & ActiveSheet.Cells(rows.Count, 1).End(xlUp).row)
    fileName = cell.Value
    sheetName = Left(cell.Offset(0, 1).Value, InStrRev(cell.Offset(0, 1).Value, ".") - 1)

    ' ターゲットブックが存在するか確認し、存在しなければ作成
    On Error Resume Next
    Set targetWorkbook = Workbooks.Open(folderPath & fileName)
    If Err.Number <> 0 Then
        Set targetWorkbook = Workbooks.Add
        targetWorkbook.SaveAs folderPath & fileName
    End If
    On Error GoTo 0

    ' ソースブックを開く
    Set sourceWorkbook = Workbooks.Open(folderPath & cell.Offset(0, 1).Value)

    ' ソースブックに複数シートがある場合はエラーを表示して停止
    If sourceWorkbook.Sheets.Count > 1 Then
        MsgBox "エラー: " & sourceWorkbook.Name & " に複数のシートがあります。処理を中止します。"
        sourceWorkbook.Close False
        targetWorkbook.Close False
        Exit Sub
    End If

    Set sourceSheet = sourceWorkbook.Sheets(1)

    ' ソースシートをターゲットブックにコピー
    sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
    targetWorkbook.Sheets(targetWorkbook.Sheets.Count).Name = sheetName

    ' ソースブックを保存せずに閉じる
    sourceWorkbook.Close False

    ' 空白のシートを削除
    For Each ws In targetWorkbook.Sheets
        If WorksheetFunction.CountA(ws.Cells) = 0 Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws

    ' 各シートを100%表示にし、A1セルにフォーカスを当てる
    For Each ws In targetWorkbook.Sheets
        ws.Activate
        ActiveWindow.Zoom = 100
        ws.Cells(1, 1).Select
    Next ws

    ' 一番左のシートをアクティブにする
    targetWorkbook.Sheets(1).Activate

    ' ターゲットブックを保存して閉じる
    targetWorkbook.Close True

    ' 進捗状況を更新
    processedFiles = processedFiles + 1
    Application.StatusBar = "進捗: " & Format(processedFiles / totalFiles, "0%") & " 完了"
Next cell

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

MsgBox "シートの登録が完了しました！"

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 columns As Integer
Dim shapeCounts As Variant
Dim currentShape As Integer
Dim shapeIndex As Integer
Dim currentRow As Integer
Dim currentColumn As Integer

' 列の数を入力するためのInputBoxを表示
columns = InputBox("何列にしますか？（区切る数より多く）", "列の設定", 3)
' 作る個数をスペースで区切って入力するためのInputBoxを表示
shapeCounts = Split(InputBox("作る個数をスペースで区切って入力してください（例：5 3 3 3 3 3）", "個数の設定", "5 3 3 3 3 3"))

' 新しいテキストボックスを作成
Set originalShape = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 4.52 * 28.35, 1.71 * 28.35) ' cmをポイントに変換
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 = 10
verticalSpacing = 20

' 指定された個数で複製
currentShape = 1
currentRow = 0
currentColumn = 0
For shapeIndex = 0 To UBound(shapeCounts)
    For i = 1 To CInt(shapeCounts(shapeIndex))
        If currentShape > 1 Then
            ' 複製を作成
            Set newShape = originalShape.Duplicate
            ' 新しい位置を設定
            newShape.Left = originalShape.Left + (originalShape.Width + horizontalSpacing) * currentColumn
            newShape.Top = originalShape.Top + (originalShape.Height + verticalSpacing) * currentRow
            ' デフォルトのフォントを設定
            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
        currentShape = currentShape + 1
        currentColumn = currentColumn + 1
        If currentColumn >= columns Then
            currentColumn = 0
            currentRow = currentRow + 1
        End If
    Next i
    currentRow = currentRow + 1 ' 各塊の間に1行空ける
    currentColumn = 0
Next shapeIndex

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
Dim ws As Worksheet
Dim activeWs As Worksheet

' シート「WORK」を設定
Set ws = Worksheets("WORK")
' アクティブシートを設定
Set activeWs = ActiveSheet

' シート「WORK」内の最後の行を取得
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row

' 空のテキストボックスに値を埋める
i = 1
For Each shp In activeWs.Shapes
    If shp.Type = msoTextBox Then
        If shp.TextFrame.Characters.text = "" Then
            If i <= lastRow Then
                ' 1行目と2行目の内容を設定
                firstLine = ws.Cells(i, "E").Value
                secondLine = ws.Cells(i, "F").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

Excelオブジェクトを作成

$Excel = New-Object -ComObject Excel.Application
$Excel.Visible = $false

PERSONAL.XLSBファイルを開く

$personalWorkbookPath = “C:\Users\anbtk\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB”
$Workbook = $Excel.Workbooks.Open($personalWorkbookPath)

マクロを実行

$Excel.Run(“PERSONAL.XLSB!test”)

変更を保存せずにファイルを閉じる

$Workbook.Close($false)

Excelを終了

$Excel.Quit()

COMオブジェクトの解放

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($Excel) | Out-Null

Sub シェイプのテキスト一覧A()

Application.ScreenUpdating = False

Dim folderPath As String
Dim fileName As String
Dim targetWb As Workbook
Dim resultWb As Workbook
Dim resultWs As Worksheet
Dim row As Long
Dim resultFilePath As String

‘ フォルダのパスを取得
folderPath = InputBox(“操作対象になるフォルダのパスを入力してください”, “フォルダの選択”)
If Right(folderPath, 1) <> “\” Then folderPath = folderPath & “\”

‘ 結果を出力する新しいブックを作成
Set resultWb = Workbooks.Add
Set resultWs = resultWb.sheets(1)
resultWs.Name = “シェイプの一覧”

‘ 見出しを設定
resultWs.Cells(1, 1).Value = “ブック名”
resultWs.Cells(1, 2).Value = “シート名”
resultWs.Cells(1, 3).Value = “グループ名”
resultWs.Cells(1, 4).Value = “オブジェクト名”
resultWs.Cells(1, 5).Value = “テキスト”
resultWs.Cells(1, 6).Value = “TBL”

‘ 見出しの書式設定
With resultWs.Range(“A1:F1”)
.Interior.Color = RGB(255, 255, 0) ‘ 背景を黄色に設定
.HorizontalAlignment = xlCenter ‘ センタリング
.Font.Bold = True
End With

‘ 1行目を固定
resultWs.rows(“2:2”).Select
ActiveWindow.FreezePanes = True

row = 2

‘ フォルダ内のすべてのExcelファイルをループ
fileName = Dir(folderPath & “.xls“)
Do While fileName <> “”
Set targetWb = Workbooks.Open(folderPath & fileName)

' 各ワークシートをループ
Dim ws As Worksheet
For Each ws In targetWb.Worksheets
    ' 各シェイプをループ
    Dim targetShape As shape
    For Each targetShape In ws.Shapes
        Call シェイプのテキスト一覧A_1(targetShape, resultWs, row, "", ws.Name, targetWb.Name)
    Next targetShape
Next ws

targetWb.Close False
fileName = Dir

Loop

‘ セル幅を最適化
resultWs.columns(“A:F”).AutoFit

‘ E列のテキストを大文字に変換
Dim lastRow As Long
lastRow = resultWs.Cells(resultWs.rows.Count, “E”).End(xlUp).row
Dim i As Long
For i = 2 To lastRow
resultWs.Cells(i, 5).Value = UCase(resultWs.Cells(i, 5).Value)

' (TBL_ を含むテキストを抽出してF列に書き出す
Dim text As String
text = resultWs.Cells(i, 5).Value
If InStr(text, "(TBL_") > 0 Then
    Dim startPos As Long
    Dim endPos As Long
    startPos = InStr(text, "(TBL_")
    endPos = InStr(startPos, text, ")")
    If endPos > startPos Then
        resultWs.Cells(i, 6).Value = Mid(text, startPos + 1, endPos - startPos - 1)
    End If
End If

Next i

‘ 結果ブックを指定されたフォルダに保存
resultFilePath = folderPath & “シェイプの一覧結果.xlsx”
resultWb.SaveAs resultFilePath
resultWb.Close False

Application.ScreenUpdating = True

End Sub

Sub シェイプのテキスト一覧A_1(targetShape As shape, resultWs As Worksheet, ByRef row As Long, groupName As String, sheetName As String, bookName As String)
Dim i As Long
Dim shapeName As String

shapeName = targetShape.Name

‘ グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
For i = 1 To targetShape.GroupItems.Count
Call シェイプのテキスト一覧A_1(targetShape.GroupItems(i), resultWs, row, shapeName, sheetName, bookName)
Next i
Else
‘ テキストがある場合
If targetShape.TextFrame2.HasText Then
resultWs.Cells(row, 1).Value = bookName
resultWs.Cells(row, 2).Value = sheetName
resultWs.Cells(row, 3).Value = groupName
resultWs.Cells(row, 4).Value = shapeName
resultWs.Cells(row, 5).Value = targetShape.TextFrame2.textRange.text
row = row + 1
End If
End If
End Sub

Sub 結果の確認と登録()

Application.ScreenUpdating = False

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lastRow As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
Dim i As Long, j As Long
Dim bookName As String, sheetName As String, groupName As String
Dim filePath As String

‘ フルパスを入力
filePath = InputBox(“対象のシートのフルパスを入力してください:”)

‘ ワークブックを開く
On Error Resume Next
Set ws = Workbooks.Open(filePath).sheets(“シェイプの一覧”)
On Error GoTo 0

If ws Is Nothing Then
MsgBox “指定されたファイルを開けませんでした。”
Exit Sub
End If

‘ G列のタイトルに「削除」と入力
ws.Cells(1, “G”).Value = “削除”

‘ H列のタイトルに「主キー」と入力
ws.Cells(1, “H”).Value = “主キー”

‘ I列のタイトルに「なし」と入力
ws.Cells(1, “I”).Value = “なし”

‘ J列のタイトルに「論理DB」と入力
ws.Cells(1, “J”).Value = “論理DB”

‘ 最終行を取得
lastRow = ws.Cells(ws.rows.Count, “E”).End(xlUp).row

‘ E列を大文字に変換し、トリムして改行や空白を削除
For i = 2 To lastRow
ws.Cells(i, “E”).Value = Trim(UCase(Replace(ws.Cells(i, “E”).Value, vbLf, “”)))
Next i

‘ F列をループして「TBL_XX」を含む行を探す
For i = 2 To lastRow
If InStr(ws.Cells(i, “F”).Value, “TBL_XX”) > 0 Then
bookName = ws.Cells(i, “A”).Value
sheetName = ws.Cells(i, “B”).Value
groupName = ws.Cells(i, “C”).Value

    For j = 2 To lastRow
        If ws.Cells(j, "A").Value = bookName And _
           ws.Cells(j, "B").Value = sheetName And _
           ws.Cells(j, "C").Value = groupName Then
            ws.Cells(j, "G").Value = 1
        End If
    Next j
End If

Next i

‘ E列をループして「●」で始まる行を探す
For i = 2 To lastRow
If Left(ws.Cells(i, “E”).Value, 1) = “●” Then
ws.Cells(i, “H”).Value = 1
End If
Next i

‘ E列をループして「なし」を含む行を探す
For i = 2 To lastRow
If InStr(ws.Cells(i, “E”).Value, “なし”) > 0 Then
ws.Cells(i, “I”).Value = 1
End If
Next i

‘ G列、H列、I列、F列がすべて空白の行のF列に0を登録
For i = 2 To lastRow
If IsEmpty(ws.Cells(i, “G”)) And IsEmpty(ws.Cells(i, “H”)) And IsEmpty(ws.Cells(i, “I”)) And IsEmpty(ws.Cells(i, “F”)) Then
ws.Cells(i, “F”).Value = 0
End If
Next i

‘ A列、B列、C列、F列を昇順でソート
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=ws.Range(“A2:A” & lastRow), Order:=xlAscending
ws.Sort.SortFields.Add Key:=ws.Range(“B2:B” & lastRow), Order:=xlAscending
ws.Sort.SortFields.Add Key:=ws.Range(“C2:C” & lastRow), Order:=xlAscending
ws.Sort.SortFields.Add Key:=ws.Range(“F2:F” & lastRow), Order:=xlAscending
With ws.Sort
.SetRange ws.Range(“A1:J” & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

‘ F列に0がある行のE列の内容をJ列に記入
For i = 2 To lastRow
If ws.Cells(i, “F”).Value = 0 And Not IsEmpty(ws.Cells(i, “F”)) Then
ws.Cells(i, “J”).Value = ws.Cells(i, “E”).Value
End If
Next i

‘ 1行目のタイトルをセンタリング、背景を黄色にし、固定してフィルタをかける
With ws.rows(1)
.HorizontalAlignment = xlCenter
.Interior.Color = RGB(255, 255, 0)
End With
ws.rows(2).Select
ActiveWindow.FreezePanes = True

‘ フィルタがかかっていない場合にフィルタをかける
If Not ws.AutoFilterMode Then
ws.rows(1).AutoFilter
End If

‘ 列幅を最適化
ws.columns(“A:J”).AutoFit

‘ 新しいシートを作成してデータをコピー
Set ws2 = ws.Parent.sheets.Add(After:=ws.Parent.sheets(ws.Parent.sheets.Count))
ws2.Name = “シェイプの一覧2”
ws.rows.Copy Destination:=ws2.rows

‘ G列、H列、I列に1がある行を削除
For i = lastRow To 2 Step -1
If ws2.Cells(i, “G”).Value = 1 Or ws2.Cells(i, “H”).Value = 1 Or ws2.Cells(i, “I”).Value = 1 Then
ws2.rows(i).Delete
End If
Next i

‘ 列幅を最適化
For i = 1 To ws2.columns.Count
ws2.columns(i).AutoFit
Next i

‘ F列に記入があり、J列が空白の部分は上の行の内容をコピーして記入
For i = 2 To lastRow
If Not IsEmpty(ws2.Cells(i, “F”)) And IsEmpty(ws2.Cells(i, “J”)) Then
ws2.Cells(i, “J”).Value = ws2.Cells(i – 1, “J”).Value
End If
Next i

‘ K列のタイトルを設定
ws2.Cells(1, “K”).Value = “サブシステム名”

‘ A列の内容で半角および全角の（と）で囲まれている内容をK列に記入
For i = 2 To lastRow
If InStr(ws2.Cells(i, “A”).Value, “(“) > 0 And InStr(ws2.Cells(i, “A”).Value, “)”) > 0 Then
ws2.Cells(i, “K”).Value = Mid(ws2.Cells(i, “A”).Value, InStr(ws2.Cells(i, “A”).Value, “(“) + 1, InStr(ws2.Cells(i, “A”).Value, “)”) – InStr(ws2.Cells(i, “A”).Value, “(“) – 1)
ElseIf InStr(ws2.Cells(i, “A”).Value, “（”) > 0 And InStr(ws2.Cells(i, “A”).Value, “）”) > 0 Then
ws2.Cells(i, “K”).Value = Mid(ws2.Cells(i, “A”).Value, InStr(ws2.Cells(i, “A”).Value, “（”) + 1, InStr(ws2.Cells(i, “A”).Value, “）”) – InStr(ws2.Cells(i, “A”).Value, “（”) – 1)
End If
Next i

‘ ワークブックを保存（閉じない）
ws.Parent.Save

‘ シートを設定
Set ws3 = ws.Parent.sheets.Add(After:=ws2)
ws3.Name = “シェイプの一覧3”

‘ 最終行を取得
lastRow2 = ws2.Cells(ws2.rows.Count, “F”).End(xlUp).row
lastRow3 = ws3.Cells(ws3.rows.Count, “A”).End(xlUp).row + 1

‘ F列が0でないものをコピー
j = lastRow3
For i = 2 To lastRow2
If ws2.Cells(i, “F”).Value <> 0 Then
ws3.Cells(j, “A”).Value = ws2.Cells(i, “F”).Value
ws3.Cells(j, “B”).Value = ws2.Cells(i, “K”).Value
ws3.Cells(j, “C”).Value = ws2.Cells(i, “J”).Value
j = j + 1
End If
Next i

‘ A1からC1のセルを選択
With ws3.Range(“A1:C1”)
‘ 背景色を黄色に設定
.Interior.Color = RGB(255, 255, 0)
‘ センタリング
.HorizontalAlignment = xlCenter
‘ フィルタの追加
.AutoFilter
End With

‘ A列のタイトルに「TBL」と入力
ws3.Cells(1, “A”).Value = “TBL”

‘ B列のタイトルに「サブシステム」と入力
ws3.Cells(1, “B”).Value = “サブシステム”

‘ C列のタイトルに「論理DB」と入力
ws3.Cells(1, “C”).Value = “論理DB”

‘ 2行目を選択して固定
ws3.rows(“2:2”).Select
ActiveWindow.FreezePanes = True

‘ 列幅を最適化
ws3.columns(“A:C”).AutoFit

Application.ScreenUpdating = True

Application.WindowState = xlMaximized
ActiveWindow.Zoom = 100
Range(“a1”).Select

End Sub

Sub test()

Call シェイプのテキスト一覧A
Call 結果の確認と登録

End Sub

Sub シェイプのテキスト一覧A()
Dim ws As Worksheet
Dim outputWs As Worksheet
Dim targetShape As shape
Dim row As Long
Dim folderPath As String
Dim fileName As String
Dim targetWb As Workbook
Dim newWb As Workbook
Dim fso As Object
Dim outputFilePath As String

' フォルダのフルパスを取得
folderPath = InputBox("作業用フォルダのフルパスを入力してください", "フォルダの選択")
If folderPath = "" Then
    MsgBox "フォルダのパスが入力されていません。"
    Exit Sub
End If
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

outputFilePath = folderPath & "シェイプのテキスト一覧.xlsx"

' シェイプのテキスト一覧.XLSX ファイルを削除
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(outputFilePath) Then
    fso.DeleteFile outputFilePath
End If

' フォルダ内の全てのエクセルファイルを開く
fileName = Dir(folderPath & "*.xlsx")

' 新しいブックを作成
Set newWb = Workbooks.Add
' 結果を出力する新しいシートを作成
Set outputWs = newWb.sheets(1)
outputWs.Name = "シェイプのテキスト一覧"

' 見出しを設定
outputWs.Cells(1, 1).Value = "ブック名"
outputWs.Cells(1, 2).Value = "シート名"
outputWs.Cells(1, 3).Value = "グループ名"
outputWs.Cells(1, 4).Value = "シェイプ名"
outputWs.Cells(1, 5).Value = "テキスト"

' 見出しの書式設定
With outputWs.Range("A1:E1")
    .Interior.Color = RGB(255, 255, 0) ' 背景を黄色に設定
    .HorizontalAlignment = xlCenter ' センタリング
    .Font.Bold = True
End With

row = 2

Do While fileName <> ""
    Set targetWb = Workbooks.Open(folderPath & fileName)

    ' 各ワークシートをループ
    For Each ws In targetWb.Worksheets
        ' 各シェイプをループ
        For Each targetShape In ws.Shapes
            Call シェイプのテキスト一覧A_1(targetShape, outputWs, row, "", ws.Name, fileName)
        Next targetShape
    Next ws

    targetWb.Close False
    fileName = Dir
Loop

' セル幅を最適化
outputWs.columns("A:E").AutoFit

' 新しいファイルに保存（既存ファイルがあれば上書き）
On Error GoTo SaveError
Application.DisplayAlerts = False
newWb.SaveAs fileName:=outputFilePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
On Error GoTo 0

MsgBox "ファイルは正常に保存されました。"
Exit Sub

SaveError:
MsgBox “ファイルを保存できませんでした。エラー: ” & Err.Description
Application.DisplayAlerts = True
End Sub

Sub シェイプのテキスト一覧A_1(targetShape As shape, outputWs As Worksheet, ByRef row As Long, groupName As String, sheetName As String, bookName As String)
Dim i As Long
Dim shapeName As String

shapeName = targetShape.Name

' グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
    For i = 1 To targetShape.GroupItems.Count
        Call シェイプのテキスト一覧A_1(targetShape.GroupItems(i), outputWs, row, shapeName, sheetName, bookName)
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        outputWs.Cells(row, 1).Value = bookName
        outputWs.Cells(row, 2).Value = sheetName
        outputWs.Cells(row, 3).Value = groupName
        outputWs.Cells(row, 4).Value = shapeName
        outputWs.Cells(row, 5).Value = targetShape.TextFrame2.textRange.Text
        row = row + 1
    End If
End If

End Sub

Sub シェイプのテキスト一覧A()
Dim ws As Worksheet
Dim outputWs As Worksheet
Dim targetShape As shape
Dim row As Long
Dim workbookPath As String
Dim targetWb As Workbook

' ブックのフルパスを取得
workbookPath = InputBox("操作対象になるブックのフルパスを入力してください", "ブックの選択")

' ブックを開く
Set targetWb = Workbooks.Open(workbookPath)

' 既存のシェイプの一覧シートを削除
Application.DisplayAlerts = False
On Error Resume Next
Set outputWs = targetWb.sheets("シェイプの一覧")
If Not outputWs Is Nothing Then
    outputWs.Delete
End If
On Error GoTo 0
Application.DisplayAlerts = True

' 結果を出力する新しいシートを作成
Set outputWs = targetWb.sheets.Add
outputWs.Name = "シェイプの一覧"

' 見出しを設定
outputWs.Cells(1, 1).Value = "シート名"
outputWs.Cells(1, 2).Value = "グループ名"
outputWs.Cells(1, 3).Value = "オブジェクト名"
outputWs.Cells(1, 4).Value = "テキスト"

' 見出しの書式設定
With outputWs.Range("A1:D1")
    .Interior.Color = RGB(255, 255, 0) ' 背景を黄色に設定
    .HorizontalAlignment = xlCenter ' センタリング
    .Font.Bold = False
End With

' 1行目を固定
outputWs.rows("2:2").Select
ActiveWindow.FreezePanes = True

row = 2

' 各ワークシートをループ
For Each ws In targetWb.Worksheets
    ' 各シェイプをループ
    For Each targetShape In ws.Shapes
        Call シェイプのテキスト一覧A_1(targetShape, outputWs, row, "", ws.Name)
    Next targetShape
Next ws

' セル幅を最適化
outputWs.columns("A:D").AutoFit

End Sub

Sub シェイプのテキスト一覧A_1(targetShape As shape, outputWs As Worksheet, ByRef row As Long, groupName As String, sheetName As String)
Dim i As Long
Dim shapeName As String

shapeName = targetShape.Name

' グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
    For i = 1 To targetShape.GroupItems.Count
        Call シェイプのテキスト一覧A_1(targetShape.GroupItems(i), outputWs, row, shapeName, sheetName)
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        outputWs.Cells(row, 1).Value = sheetName
        outputWs.Cells(row, 2).Value = groupName
        outputWs.Cells(row, 3).Value = shapeName
        outputWs.Cells(row, 4).Value = targetShape.TextFrame2.textRange.Text
        row = row + 1
    End If
End If

End Sub

Sub シェイプ内のスペースまでを削除()
Dim ws As Worksheet
Dim targetShape As shape
Dim workbookPath As String
Dim targetWb As Workbook

' ブックのフルパスを取得
workbookPath = InputBox("操作対象になるブックのフルパスを入力してください", "ブックの選択")

' ブックを開く
Set targetWb = Workbooks.Open(workbookPath)

' 各ワークシートをループ
For Each ws In targetWb.Worksheets
    ' 各シェイプをループ
    For Each targetShape In ws.Shapes
        Call 削除プロセス(targetShape)
    Next targetShape
Next ws

End Sub

Sub 削除プロセス(targetShape As shape)
Dim i As Long
Dim shapeText As String
Dim spacePosition As Long

' グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
    For i = 1 To targetShape.GroupItems.Count
        Call 削除プロセス(targetShape.GroupItems(i))
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        shapeText = targetShape.TextFrame2.textRange.Text

        ' 半角スペースと全角スペースをすべて削除
        Do
            spacePosition = InStr(shapeText, " ")
            If spacePosition > 0 Then
                shapeText = Mid(shapeText, spacePosition + 1)
            End If
        Loop While spacePosition > 0

        Do
            spacePosition = InStr(shapeText, "　")
            If spacePosition > 0 Then
                shapeText = Mid(shapeText, spacePosition + 1)
            End If
        Loop While spacePosition > 0

        targetShape.TextFrame2.textRange.Text = shapeText
    End If
End If

End Sub

2024.11.07(木)

右クリックを昔風に reg.exe add “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}\InprocServer32” /f /ve

右クリックを標準設定に戻す reg.exe delete “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}” /f

2024.11.1

vbCrLf ではなく、vbLf でうまくいった。

Sub 二行目をMeiryo_UIにできた()
Dim shape As shape
Dim textBoxText As String
Dim lines As Variant
Dim secondLineStart As Long
Dim secondLineLength As Longc

For Each shape In ActiveSheet.Shapes
    If shape.TextFrame2.HasText Then
        textBoxText = shape.TextFrame2.TextRange.Text
        lines = Split(textBoxText, vbLf)

        If UBound(lines) >= 1 Then ' 2行目が存在する場合
            secondLineStart = Len(lines(0)) + 2 ' 1行目の長さ + 改行2文字

            If Len(lines(1)) > 0 Then
                secondLineLength = Len(lines(1))
                With shape.TextFrame2.TextRange.Characters(secondLineStart, secondLineLength).Font
                    .Name = "Meiryo UI"
                    .NameFarEast = "Meiryo UI"
                    .NameComplexScript = "Meiryo UI"
                    .Size = 13
                End With
            End If
        End If
    End If
Next shape

End Sub

Sub テキストが全て表示されていないシェイプの2行目をMeiryo_8point()
Dim shape As shape
Dim textFrame As TextFrame2
Dim textRange As TextRange2
Dim textBoxText As String
Dim lines As Variant
Dim secondLineStart As Long
Dim secondLineLength As Long

For Each shape In ActiveSheet.Shapes
    If shape.TextFrame2.HasText Then
        Set textFrame = shape.TextFrame2
        Set textRange = textFrame.textRange

        ' テキストの高さをチェック
        If textRange.BoundHeight > shape.Height Then
            Debug.Print "テキストがすべて表示されていないシェイプ: " & shape.Name

            ' テキストがすべて表示されていないシェイプの2行目を更新
            textBoxText = textRange.Text
            lines = Split(textBoxText, vbLf)

            If UBound(lines) >= 1 Then ' 2行目が存在する場合
                secondLineStart = Len(lines(0)) + 2 ' 1行目の長さ + 改行2文字

                If Len(lines(1)) > 0 Then
                    secondLineLength = Len(lines(1))
                    With textRange.Characters(secondLineStart, secondLineLength).Font
                        .Name = "Meiryo UI"
                        .NameFarEast = "Meiryo UI"
                        .NameComplexScript = "Meiryo UI"
                        .Size = 8
                    End With
                End If
            End If
        End If
    End If
Next shape

End Sub

右クリックを昔風に reg.exe add “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}\InprocServer32” /f /ve

右クリックを標準設定に戻す reg.exe delete “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}” /f

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