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