diff --git a/機能仕様書作成.xlsm b/機能仕様書作成.xlsm index aa953ff..64df4ff 100644 Binary files a/機能仕様書作成.xlsm and b/機能仕様書作成.xlsm differ diff --git a/機能仕様書作成/Module1.bas b/機能仕様書作成/Module1.bas index a16397b..ff4687a 100644 --- a/機能仕様書作成/Module1.bas +++ b/機能仕様書作成/Module1.bas @@ -191,3 +191,4 @@ Sub ExportCustomizeFunctionsToMarkdownFile() End Sub + diff --git a/機能仕様書作成/Module2.bas b/機能仕様書作成/Module2.bas new file mode 100644 index 0000000..295885c --- /dev/null +++ b/機能仕様書作成/Module2.bas @@ -0,0 +1,78 @@ +Attribute VB_Name = "Module2" +Option Explicit + +Sub ExcelFileImport() + + Application.ScreenUpdating = False + + Dim fd As FileDialog + Dim selectedPath As String + Dim wb As Workbook + Dim ws As Worksheet + Dim sheetList As String + + + Dim tgtSheet As Worksheet + Set tgtSheet = ActiveSheet + + '======================== + ' ファイル選択ダイアログ + '======================== + Set fd = Application.FileDialog(msoFileDialogFilePicker) + With fd + .Title = "Excelファイルを選択してください" + .Filters.Clear + .Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls" + .AllowMultiSelect = False + + If .Show <> -1 Then Exit Sub + selectedPath = .SelectedItems(1) + End With + + '======================== + ' ファイルパスを C3 に出力 + '======================== + tgtSheet.Range("C3").Value = selectedPath + + '======================== + ' 出力先初期化 + '======================== + tgtSheet.Range("C4").MergeArea.ClearContents + sheetList = "" + + '======================== + ' Excelファイルを開く + '======================== + Set wb = Workbooks.Open(Filename:=selectedPath, ReadOnly:=True) + + '======================== + ' シート名を連結(セル内改行) + '======================== + For Each ws In wb.Worksheets + If sheetList = "" Then + sheetList = ws.Name + Else + sheetList = sheetList & vbLf & ws.Name + End If + Next ws + + 'MsgBox (sheetList) + + '======================== + ' C5(結合セル)に出力 + '======================== + With tgtSheet.Range("C4") + .MergeArea.Value = sheetList + .WrapText = True + End With + + + '======================== + ' 後処理 + '======================== + wb.Close SaveChanges:=False + Set wb = Nothing + + Application.ScreenUpdating = True + +End Sub