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 folderPath As String
Dim fileName As String
Dim targetWb As Workbook
Dim newWb As Workbook
Dim fso As Object
Dim outputFilePath As String<\/p>\n\n\n\n
' \u30d5\u30a9\u30eb\u30c0\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u53d6\u5f97\nfolderPath = InputBox(\"\u4f5c\u696d\u7528\u30d5\u30a9\u30eb\u30c0\u306e\u30d5\u30eb\u30d1\u30b9\u3092\u5165\u529b\u3057\u3066\u304f\u3060\u3055\u3044\", \"\u30d5\u30a9\u30eb\u30c0\u306e\u9078\u629e\")\nIf folderPath = \"\" Then\n MsgBox \"\u30d5\u30a9\u30eb\u30c0\u306e\u30d1\u30b9\u304c\u5165\u529b\u3055\u308c\u3066\u3044\u307e\u305b\u3093\u3002\"\n Exit Sub\nEnd If\nIf Right(folderPath, 1) <> \"\\\" Then folderPath = folderPath & \"\\\"\n\noutputFilePath = folderPath & \"\u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7.xlsx\"\n\n' \u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7.XLSX \u30d5\u30a1\u30a4\u30eb\u3092\u524a\u9664\nSet fso = CreateObject(\"Scripting.FileSystemObject\")\nIf fso.FileExists(outputFilePath) Then\n fso.DeleteFile outputFilePath\nEnd If\n\n' \u30d5\u30a9\u30eb\u30c0\u5185\u306e\u5168\u3066\u306e\u30a8\u30af\u30bb\u30eb\u30d5\u30a1\u30a4\u30eb\u3092\u958b\u304f\nfileName = Dir(folderPath & \"*.xlsx\")\n\n' \u65b0\u3057\u3044\u30d6\u30c3\u30af\u3092\u4f5c\u6210\nSet newWb = Workbooks.Add\n' \u7d50\u679c\u3092\u51fa\u529b\u3059\u308b\u65b0\u3057\u3044\u30b7\u30fc\u30c8\u3092\u4f5c\u6210\nSet outputWs = newWb.sheets(1)\noutputWs.Name = \"\u30b7\u30a7\u30a4\u30d7\u306e\u30c6\u30ad\u30b9\u30c8\u4e00\u89a7\"\n\n' \u898b\u51fa\u3057\u3092\u8a2d\u5b9a\noutputWs.Cells(1, 1).Value = \"\u30d6\u30c3\u30af\u540d\"\noutputWs.Cells(1, 2).Value = \"\u30b7\u30fc\u30c8\u540d\"\noutputWs.Cells(1, 3).Value = \"\u30b0\u30eb\u30fc\u30d7\u540d\"\noutputWs.Cells(1, 4).Value = \"\u30b7\u30a7\u30a4\u30d7\u540d\"\noutputWs.Cells(1, 5).Value = \"\u30c6\u30ad\u30b9\u30c8\"\n\n' \u898b\u51fa\u3057\u306e\u66f8\u5f0f\u8a2d\u5b9a\nWith outputWs.Range(\"A1:E1\")\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 = True\nEnd With\n\nrow = 2\n\nDo While fileName <> \"\"\n Set targetWb = Workbooks.Open(folderPath & fileName)\n\n ' \u5404\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u3092\u30eb\u30fc\u30d7\n For 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, fileName)\n Next targetShape\n Next ws\n\n targetWb.Close False\n fileName = Dir\nLoop\n\n' \u30bb\u30eb\u5e45\u3092\u6700\u9069\u5316\noutputWs.columns(\"A:E\").AutoFit\n\n' \u65b0\u3057\u3044\u30d5\u30a1\u30a4\u30eb\u306b\u4fdd\u5b58\uff08\u65e2\u5b58\u30d5\u30a1\u30a4\u30eb\u304c\u3042\u308c\u3070\u4e0a\u66f8\u304d\uff09\nOn Error GoTo SaveError\nApplication.DisplayAlerts = False\nnewWb.SaveAs fileName:=outputFilePath, FileFormat:=xlOpenXMLWorkbook\nApplication.DisplayAlerts = True\nOn Error GoTo 0\n\nMsgBox \"\u30d5\u30a1\u30a4\u30eb\u306f\u6b63\u5e38\u306b\u4fdd\u5b58\u3055\u308c\u307e\u3057\u305f\u3002\"\nExit Sub<\/code><\/pre>\n\n\n\nSaveError:
MsgBox “\u30d5\u30a1\u30a4\u30eb\u3092\u4fdd\u5b58\u3067\u304d\u307e\u305b\u3093\u3067\u3057\u305f\u3002\u30a8\u30e9\u30fc: ” & Err.Description
Application.DisplayAlerts = True
End 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, bookName 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, bookName)\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 = bookName\n outputWs.Cells(row, 2).Value = sheetName\n outputWs.Cells(row, 3).Value = groupName\n outputWs.Cells(row, 4).Value = shapeName\n outputWs.Cells(row, 5).Value = targetShape.TextFrame2.textRange.Text\n row = row + 1\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 folde … <\/p>\n