エクセルシートをそれぞれ保存するマクロを作成したい

前提・実現したいこと

エクセルに13個のシートがあります。

シート名は、以下の通りです。
表紙,1,2,3,4,5,6,7,8,9,10,11,12

１．表紙のセルA2に入力した文字をフォルダ名にしてデスクトップに保存
２．シート1～12のシートをそれぞれCSVファイルにして１のフォルダに保存

というマクロを組みたいですが、うまくいきません。
試したことへ作成したマクロを貼り付けました。

発生している問題・エラーメッセージ

エラーメッセージ

該当のソースコード

ソースコード

試したこと

Sub 切り分け()

ActiveWindow.WindowState = xlMinimized

Dim path As String
Dim WSH As Object
Dim OpenFileName As String
Dim FolderName As String

'作成するフォルダ名
FolderName = Range("A2").Value

'特殊フォルダの取得
Set WSH = CreateObject("WScript.Shell")

'デスクトップの位置を取得
path = WSH.SpecialFolders("Desktop") & ""

'カレントフォルダ変更
ChDir path

'デスクトップに指定したフォルダがない場合作成する
If Dir(path & FolderName, vbDirectory) = "" Then

MkDir path & "\" & FolderName

Application.ScreenUpdating = False

End If

Sheets("7").Select
Sheets("7").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\7.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

Sheets("8").Select
 Sheets("8").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\8.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

Sheets("9").Select
 Sheets("9").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\9.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

Sheets("10").Select
 Sheets("10").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\10.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close


Sheets("11").Select
 Sheets("11").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\11.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close


Sheets("12").Select
 Sheets("12").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\12.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close


Sheets("1").Select
 Sheets("1").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\1.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close


Sheets("2").Select
 Sheets("2").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\2.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

Sheets("3(うるう年調整必要)").Select
 Sheets("3(うるう年調整必要)").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\3.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close


Sheets("4").Select
 Sheets("4").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\4.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

 Sheets("5").Select
 Sheets("5").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\5.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

 Sheets("6").Select
 Sheets("6").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Users\bd11\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\bd11\Desktop\6.csv", FileFormat:= _
    xlCSV, CreateBackup:=False
ActiveWindow.Close

Sheets("スケジュール").Select

End Sub

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

jinoji

2021/05/14 03:38

うまくいきません、というのをもう少し具体的に言うと、何がどうなるのですか？

行動規範の内容に同意します

回答2件

ベストアンサー

ExcelVBA
1Option Explicit
2
3Sub test()
4    Dim i As Long
5    Dim FolName As String
6    Dim ws As Worksheet
7    
8    '保存先フォルダー名取得
9    FolName = GetFolderPath(ThisWorkbook.Worksheets("集計").Range("A2").Value)
10    
11    For i = 1 To 12
12        Set ws = Nothing            '変数の初期化
13        'シートの存在確認
14        On Error Resume Next
15        Set ws = ThisWorkbook.Worksheets(CStr(i))
16        On Error GoTo 0
17        
18        'シートがあったときの処理
19        If Not ws Is Nothing Then
20            ws.Copy
21            With Workbooks(Workbooks.Count)
22                .SaveAs FolName & "\" & ws.Name & ".csv", xlCSV
23                .Close False
24            End With
25        End If
26    Next
27End Sub
28
29'保存先フォルダーの取得関数（なければ新規作成）
30Function GetFolderPath(ByVal sName As String) As String
31    Dim myPath As String
32    
33    myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & sName
34    'フォルダーの存在確認
35    If Dir(myPath, vbDirectory) = "" Then
36        MkDir myPath            'なければ作る
37    End If
38    
39    GetFolderPath = myPath
40End Function

1）同じようなことを繰り返すときは、For～Nextなどで繰り返したらいいです。
変数を上手く使って、変わらなければいけないところを変えられるように書けばよいです。

2）CSV形式のファイルは数式などの情報は含まれませんので、
敢えて明示的に値に変換しなくても保存するときに勝手に変換されます。

3）フォルダーやファイルやシート等、間違って削除することもあるので、
もう少し真面目に存在確認の結果でどうするか考えてみてもいいかもです。

※あくまでサンプルです。思いついたまま書いてテストしてないので、
バグがあればご容赦願います。自己責任で使用をお願いします。

投稿2021/05/15 00:17

mattuwan

総合スコア2163

退会済みユーザー

2021/05/15 01:42

ありがとうございます！うまく動作しました。

行動規範の内容に同意します

とりあえず。

VBA
1Dim ws As Worksheet
2Dim fn As String
3Dim wb As Workbook
4
5For Each ws In ThisWorkbook.Worksheets
6    If Not ws.Name = "表紙" Then
7        fn = path & FolderName & "\" & ws.Name & ".csv"
8        ws.Copy
9        Set wb = ActiveWorkbook
10        wb.Worksheets(1).UsedRange.Value = wb.Worksheets(1).UsedRange.Value
11        wb.SaveAs FileName:=fn, FileFormat:=xlCSV, CreateBackup:=False
12        wb.Close False
13    End If
14Next
15