マクロでシート毎に分けたあとの保存先の指定

###前提・実現したいこと
マクロで取込データを、別データのフォーマットの項目でフィルターをかけ、
指定列ごとコピーしフォーマット側にペースト、
次の項目でフィルターをかけ、指定列ごとコピーしフォーマット側にペーストを繰り返し、
フォーマット側の項目がなくなったら次シートの項目でフィルターをかけて……
というループをさせ、最終シートまで繰り返す。
というマクロです。
このマクロを回し終わった後に、
シート毎に別々の人にメールを送る機能を追加したいのですが、
一応、マスタを作成してそこから必要な情報取込、送信という処理をループさせようと考えています。
その際にシート毎のデータをメールに添付して送るのに、
シート毎にデータを保存して添付ファイルを準備するという構文をネット上で見つけ、改変したのですがマクロを回すと
デスクトップにすべて保存されます。
この構文の場合保存される場所はどうやって指定したらいいのでしょうか。
出来れば不特定多数の人が使いますので、デスクトップに決め打ちでフォルダを作り、そこに保存するようにしたいです。
皆様の知恵をお貸しください。
よろしくお願いします

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

###該当のソースコード

Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
    'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With
    
    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 2
   
    
    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
    
    Call FileSearch(folderpass, "*.csv")
   Dim dateupdate As String
   dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
   'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
   'ThisWorkbook.Worksheets(2).Name = dateupdate '
   ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
   ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)


    Dim openbook As Workbook
    Dim openbooksheet As Worksheet
    Dim lp As Long
    Dim el As Long
    Dim br As String
    'オ
    Dim c As Range, Target As Range
    Dim LastRow As Long
    '縦軸(マクロ側シート数用)
    lp = 2
    '横軸(データ側ループ管理用)
    el = 3

    
    
    Application.ScreenUpdating = False

    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)



        Set openbooksheet = openbook.Worksheets(1)
        openbooksheet.Unprotect
        
        
      Do Until lp = 28
    
        Do Until ThisWorkbook.Worksheets(lp).Cells(1, el) = ""
        
          br = ThisWorkbook.Worksheets(lp).Cells(2, el)
          
          openbooksheet.Activate
          
          Selection.AutoFilter
          openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br
          
          LastRow = 291826
          
          openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el))
          openbooksheet.Range("A1").AutoFilter
    
      
          el = el + 1
    
        Loop
         
         el = 3
         
         lp = lp + 1
      Loop
    
     
       
  
  
    openbook.Close False
    
    
    Application.ScreenUpdating = True
    Exit Sub
    
myError:
    MsgBox Err.Description
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub

 'シート毎保存部分
      
      Sub test02()
      
         Dim wb1 As Workbook
         Dim i As Long
         Dim s As Long
         Dim mo As Long

         
         
         Set wb1 = ActiveWorkbook
         
         s = wb1.Sheets.Count
         
         s = s - 1
         
          For i = 2 To s
          
             mo = ThisWorkbook.Worksheets(29).Cells(2, i)
             
             Workbooks.Add.SaveAs Filename:="AD" & i & ".xls"
             wb1.Worksheets(i).Copy before:=Workbooks(mo & ".xls").Worksheets(1)
             Workbooks(mo & ".xls").Worksheets(1).Name = mo
          
          Next i
      
      End Sub

###補足情報(言語/FW/ツール等のバージョンなど)
前回使用していたマクロを改変して作っているので謎の項目があるかもしれませんがご容赦ください。

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

回答2件

ベストアンサー

Workbook.SaveAsの引数にファイル名だけを指定すると、現在のフォルダに保存されます。デスクトップにファイルが保存されるのは、デスクトップが現在のフォルダーになっている状態で、質問のマクロを実行したからです。（質問のマクロを含むExcelファイルがデスクトップにあって、それをダブルクリックしてExcelを起動すると、デスクトップが現在のフォルダーになります）

この問題は、SaveAsの引数にフルパスのファイル名（フォルダーを指定したファイル名）を使えば解決できます。

ユーザ名が"teryyyyy2"で、デスクトップにある"kimeuchi"というフォルダーにファイルを保存する場合を想定すると、以下のような修正をしてください。

質問のコードの下から５行目

             Workbooks.Add.SaveAs Filename:="AD" & i & ".xls"

を

             Workbooks.Add.SaveAs Filename:="c:/Users/teryyyyy2/Desktop/kimeuchi/AD" & i & ".xls"

に修正。

投稿2016/06/24 06:39

coco_bauer

総合スコア6915

teryyyyy2

2016/06/24 07:00

ご回答ありがとうございます。この例で指定できるのはわかりました。ですが（kimeuchi）というフォルダを作るマクロもほしいのですがどうしたらいいでしょうか…ご助力願います。

nakit

2016/06/24 13:24

VBAではフォルダを作成するための MkDir ステートメントがあります。また、フォルダが存在するか確認するにはDir関数があります。これら2つを使うことで期待する機能を実現するコードを書くことができると思います。 ※MkDirやDirを使わずにFileSystemObjectを利用する方法もあります。

XYZA

2016/06/25 07:17 編集

横から失礼します。昨日フォルダ作成のVBAをたまたま作成してたのでおすそ分けです Dim SaveDir As String Dim book_path As String book_path = ThisWorkbook.Path SaveDir = book_path & "\" & Format(Date, "yyyymmdd") ' 今日の日付のフォルダがなければ作成する If Dir(SaveDir, vbDirectory) = "" Then MkDir SaveDir End If こちらのソースは現在のフォルダに今日日付のフォルダが無い場合は作成するというものになります。 bookpass（現在のbook保存箇所）とFormat(Date, "yyyymmdd")の箇所はお好きなものに変更して使用してください。横から失礼いたしました。

teryyyyy2

2016/06/27 01:58

v_aoyamaさんありがとうございます。おすそ分け、ありがたく使わせていただきます。

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