シェイプから内容確認の一覧表を出力

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