Sub \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7A()
Dim ws As Worksheet
Dim outputWs As Worksheet
Dim targetShape As shape
Dim row As Long
Dim workbookPath As String
Dim targetWb As Workbook<\/p>\n\n\n\n
' \u30d6\u30c3\u30af\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u53d6\u5f97\nworkbookPath = InputBox(\"\u64cd\u4f5c\u5bfe\u8c61\u306b\u306a\u308b\u30d6\u30c3\u30af\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u5165\u529b\u3057\u3066\u304f\u3060\u3055\u3044\", \"\u30d6\u30c3\u30af\u306e\u9078\u629e\")\n\n' \u30d6\u30c3\u30af\u3092\u958b\u304f\nSet targetWb = Workbooks.Open(workbookPath)\n\n' \u65e2\u5b58\u306e\u30b7\u30a7\u30a4\u30d7\u306e\u4e00\u89a7\u30b7\u30fc\u30c8\u3092\u524a\u9664\nApplication.DisplayAlerts = False\nOn Error Resume Next\nSet outputWs = targetWb.sheets(\"\u30b7\u30a7\u30a4\u30d7\u306e\u4e00\u89a7\")\nIf Not outputWs Is Nothing Then\n outputWs.Delete\nEnd If\nOn Error GoTo 0\nApplication.DisplayAlerts = True\n\n' \u7d50\u679c\u3092\u51fa\u529b\u3059\u308b\u65b0\u3057\u3044\u30b7\u30fc\u30c8\u3092\u4f5c\u6210\nSet outputWs = targetWb.sheets.Add\noutputWs.Name = \"\u30b7\u30a7\u30a4\u30d7\u306e\u4e00\u89a7\"\n\n' \u898b\u51fa\u3057\u3092\u8a2d\u5b9a\noutputWs.Cells(1, 1).Value = \"\u30b7\u30fc\u30c8\u540d\"\noutputWs.Cells(1, 2).Value = \"\u30b0\u30eb\u30fc\u30d7\u540d\"\noutputWs.Cells(1, 3).Value = \"\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u540d\"\noutputWs.Cells(1, 4).Value = \"\u30c6\u30ad\u30b9\u30c8\"\n\n' \u898b\u51fa\u3057\u306e\u66f8\u5f0f\u8a2d\u5b9a\nWith outputWs.Range(\"A1:D1\")\n .Interior.Color = RGB(255, 255, 0) ' \u80cc\u666f\u3092\u9ec4\u8272\u306b\u8a2d\u5b9a\n .HorizontalAlignment = xlCenter ' \u30bb\u30f3\u30bf\u30ea\u30f3\u30b0\n .Font.Bold = False\nEnd With\n\n' 1\u884c\u76ee\u3092\u56fa\u5b9a\noutputWs.rows(\"2:2\").Select\nActiveWindow.FreezePanes = True\n\nrow = 2\n\n' \u5404\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u3092\u30eb\u30fc\u30d7\nFor Each ws In targetWb.Worksheets\n ' \u5404\u30b7\u30a7\u30a4\u30d7\u3092\u30eb\u30fc\u30d7\n For Each targetShape In ws.Shapes\n Call \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7A_1(targetShape, outputWs, row, \"\", ws.Name)\n Next targetShape\nNext ws\n\n' \u30bb\u30eb\u5e45\u3092\u6700\u9069\u5316\noutputWs.columns(\"A:D\").AutoFit<\/code><\/pre>\n\n\n\nEnd Sub<\/p>\n\n\n\n
Sub \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7A_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<\/p>\n\n\n\n
shapeName = targetShape.Name\n\n' \u30b0\u30eb\u30fc\u30d7\u5316\u3055\u308c\u305f\u30b7\u30a7\u30a4\u30d7\u306e\u5834\u5408\nIf targetShape.Type = msoGroup Then\n For i = 1 To targetShape.GroupItems.Count\n Call \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7A_1(targetShape.GroupItems(i), outputWs, row, shapeName, sheetName)\n Next i\nElse\n ' \u30c6\u30ad\u30b9\u30c8\u304c\u3042\u308b\u5834\u5408\n If targetShape.TextFrame2.HasText Then\n outputWs.Cells(row, 1).Value = sheetName\n outputWs.Cells(row, 2).Value = groupName\n outputWs.Cells(row, 3).Value = shapeName\n outputWs.Cells(row, 4).Value = targetShape.TextFrame2.textRange.Text\n row = row + 1\n End If\nEnd If<\/code><\/pre>\n\n\n\nEnd Sub<\/p>\n\n\n\n
Sub \u30b7\u30a7\u30a4\u30d7\u5185\u306e\u30b9\u30da\u30fc\u30b9\u307e\u3067\u3092\u524a\u9664()
Dim ws As Worksheet
Dim targetShape As shape
Dim workbookPath As String
Dim targetWb As Workbook<\/p>\n\n\n\n
' \u30d6\u30c3\u30af\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u53d6\u5f97\nworkbookPath = InputBox(\"\u64cd\u4f5c\u5bfe\u8c61\u306b\u306a\u308b\u30d6\u30c3\u30af\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u5165\u529b\u3057\u3066\u304f\u3060\u3055\u3044\", \"\u30d6\u30c3\u30af\u306e\u9078\u629e\")\n\n' \u30d6\u30c3\u30af\u3092\u958b\u304f\nSet targetWb = Workbooks.Open(workbookPath)\n\n' \u5404\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u3092\u30eb\u30fc\u30d7\nFor Each ws In targetWb.Worksheets\n ' \u5404\u30b7\u30a7\u30a4\u30d7\u3092\u30eb\u30fc\u30d7\n For Each targetShape In ws.Shapes\n Call \u524a\u9664\u30d7\u30ed\u30bb\u30b9(targetShape)\n Next targetShape\nNext ws<\/code><\/pre>\n\n\n\nEnd Sub<\/p>\n\n\n\n
Sub \u524a\u9664\u30d7\u30ed\u30bb\u30b9(targetShape As shape)
Dim i As Long
Dim shapeText As String
Dim spacePosition As Long<\/p>\n\n\n\n
' \u30b0\u30eb\u30fc\u30d7\u5316\u3055\u308c\u305f\u30b7\u30a7\u30a4\u30d7\u306e\u5834\u5408\nIf targetShape.Type = msoGroup Then\n For i = 1 To targetShape.GroupItems.Count\n Call \u524a\u9664\u30d7\u30ed\u30bb\u30b9(targetShape.GroupItems(i))\n Next i\nElse\n ' \u30c6\u30ad\u30b9\u30c8\u304c\u3042\u308b\u5834\u5408\n If targetShape.TextFrame2.HasText Then\n shapeText = targetShape.TextFrame2.textRange.Text\n\n ' \u534a\u89d2\u30b9\u30da\u30fc\u30b9\u3068\u5168\u89d2\u30b9\u30da\u30fc\u30b9\u3092\u3059\u3079\u3066\u524a\u9664\n Do\n spacePosition = InStr(shapeText, \" \")\n If spacePosition > 0 Then\n shapeText = Mid(shapeText, spacePosition + 1)\n End If\n Loop While spacePosition > 0\n\n Do\n spacePosition = InStr(shapeText, \"\u3000\")\n If spacePosition > 0 Then\n shapeText = Mid(shapeText, spacePosition + 1)\n End If\n Loop While spacePosition > 0\n\n targetShape.TextFrame2.textRange.Text = shapeText\n End If\nEnd If<\/code><\/pre>\n\n\n\nEnd Sub<\/p>\n","protected":false},"excerpt":{"rendered":"
Sub \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7A()Dim ws As WorksheetDim outputWs As WorksheetDim targetShape As shapeDim row As LongDim workb … <\/p>\n