ご教授をお願いしたいです。 CSVに自動で落とすマクロを組みたいのですが。 専用の適当なエクセルを作成して以下の条件にて CSVファイルを作りたいです。 条件は以下 ●特定のフォルダにあります ※ファイルパス："\\○○\○\" ●ファルダ内には4つのエクセルがあります ・テスト①.xlsx ・テスト②.xlsx ・テスト③.xlsx ・テスト④.xlsx ・テスト⑤.xlsx ●それぞれのエクセルシートには4月～3月までシートがわかれています。 ・任意で例えば4月を選んだ場合 ※月の指定はエクセル5つとも同じ条件で構いません 頭に"4月分"など任意で名前を付けて同じフォルダ内に保存したいです。 説明不足かと思いますが、画像と合わせて内容確認して頂けると幸いです。 宜しくお願いします。

マクロを実行するための別ブックを用意して下さい。 別ブックは何処に置いても構いません。 実行すると目的のフォルダ選択ダイアログが出るので、目的のフォルダを選択して下さい。 次いで、InputBoxが出るので、シートの月数を数値で入力して下さい。 （注意：半角・全角は、シート名に合わせて下さい） Dim FolPath, Tuki Dim FSO As Object, Fol As Object, Fils As Object, MonoF As Object Dim Wb As Workbook, Ws As Worksheet, WBCsv As Workbook Dim CsvName, CsvPath Set FSO = CreateObject("Scripting.FileSystemObject") With Application.FileDialog(msoFileDialogFolderPicker)     .AllowMultiSelect = False     .InitialFileName = ThisWorkbook.Path     If .Show = True Then         FolPath = .SelectedItems(1)     Else         End     End If End With Tuki = InputBox("対象月（数値のみ）を入力して下さい。" & vbCr & _                 "      （全角・半角はシート名に合わせて）") If Tuki = "" Then End Tuki = Tuki & "月" Application.ScreenUpdating = False Set Fol = FSO.GetFolder(FolPath) Set Fils = Fol.Files For Each MonoF In Fils     If MonoF.Name <> ThisWorkbook.Name Then         If InStr(MonoF.Name, "xlsx") <> 0 Or InStr(MonoF.Name, "xlsm") <> 0 Then             If InStr(MonoF.Name, "~$") = 0 Then                 Set Wb = Workbooks.Open(MonoF)                 Set Ws = Wb.Worksheets(Tuki)                 Ws.Select                 Ws.Copy                 Set WBCsv = ActiveWorkbook                 CsvName = Tuki & "分_" & MonoF.Name                 CsvName = Replace(CsvName, "xlsx", "csv")                 CsvPath = FolPath & "\" & CsvName                 Application.DisplayAlerts = False                 WBCsv.SaveAs Filename:=CsvPath, FileFormat:=xlCSV                 WBCsv.Close                 Wb.Close                 Application.DisplayAlerts = True             End If         End If     End If Next Application.ScreenUpdating = True MsgBox "完了"

「特定のフォルダ」は Const で定義しているので、変更してください。 > ●ファルダ内には4つのエクセルがあります 当該フォルダの全 Excel ブック（*.xlsx）を対象とすることとしています。 > ・任意で例えば4月を選んだ場合 月の指定は InputBox で行うようにしています。 Sub Sample()     Const XL_DIR As String = "\\○○\○\"     Dim m As Long     m = Application.InputBox("何月分？", Type:=1)     If m < 1 Or m > 12 Then Exit Sub     Dim xlName As String: xlName = Dir(XL_DIR & "*.xlsx")     Application.ScreenUpdating = False     Do While xlName <> ""         Dim wb As Workbook         Set wb = Workbooks.Open(XL_DIR & xlName)         Dim csvName As String         csvName = m & "月分 " & Left(xlName, Len(xlName) - 4) & "csv"         On Error Resume Next         wb.Worksheets(m & "月分").SaveAs XL_DIR & csvName, xlCSVUTF8         On Error GoTo 0         wb.Close False         xlName = Dir()     Loop     Application.ScreenUpdating = True End Sub

＞"\\○○\○\" ローカルフォルダを手動で選択（フォルダー内全ての.xlsxファイルを操作します） 画像を参考にファイル名を設定 ”４月分”はコード内の定数で 同名csvファイルがある場合上書きされます シートのデータ群が不明の為 UsedRange 元がExcelですがExcelで開く想定でUTF-8 BOM付 ざっくり参考程度に Sub Sample() Dim folderPath As String Dim fileName As String Dim wb As Workbook Dim sht As Worksheet Const targetName As String = "４月分" '全て全角です '--- フォルダを指定（手動選択） With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Excelファイルがあるフォルダを選択してください" If .Show <> -1 Then Exit Sub folderPath = .SelectedItems(1) End With If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" fileName = Dir(folderPath & "*.xlsx") Application.ScreenUpdating = False Do While fileName <> "" '--- Bookを開く Set wb = Workbooks.Open(folderPath & fileName) For Each sht In wb.Sheets If sht.Name = targetName Then 'csvサブ Call ExportSheetToUTF8CSV(sht, folderPath) End If Next wb.Close False fileName = Dir() Loop Application.ScreenUpdating = True MsgBox "CSVファイルを保存しました：" & vbCrLf & folderPath, vbInformation End Sub Sub ExportSheetToUTF8CSV(ws As Worksheet, ExportPath As String) Dim arr() As Variant Dim i As Long, j As Long Dim AD As Object Dim lineText As String '--- 範囲を配列に arr = ws.UsedRange.Value '--- ADODB.StreamでUTF-8出力 Set AD = CreateObject("ADODB.Stream") With AD .Type = 2 ' テキストモード .Charset = "utf-8" ' 文字コード指定 .Open ' BOMを書き込み（Excel用） .WriteText ChrW(&HFEFF), 0 '--- データ行を書き込み For i = 1 To UBound(arr, 1) lineText = "" For j = 1 To UBound(arr, 2) lineText = lineText & arr(i, j) If j < UBound(arr, 2) Then lineText = lineText & "," Next j .WriteText lineText & vbCrLf Next i '--- Export .SaveToFile ExportPath & ws.Name _ & Left(ws.Parent.Name, InStrRev(ws.Parent.Name, ".") - 1) & ".csv", 2 ' 2 = 上書き保存 .Close End With End Sub