將新創建的工作簿保存到特定文件夾

Question

我希望你能提供幫助。 我有一段代碼。 本質上它所做的就是打開一個對話框，允許用戶選擇一個Excel工作表，然後出口到國家欄（11）對其進行過濾，然後將該國家複製並粘貼到新的工作簿中，將新的工作簿命名爲該國之後的工作簿會重複下一個國家的行動，然後保存並關閉每個工作簿。

我想改變的是這些新工作簿正在保存的位置。

當前它們被保存在存儲模板（被分割的原始工作簿）和宏的相同文件夾中。我希望新創建的工作簿現在可以保存在其他地方。這裏C：\ Users \ CONNELLP \桌面\ Claire宏\ CRO國家

任何幫助將不勝感激。

的產品圖，其中工作簿當前存儲

產品圖的原始模板的

MY CODE

Sub Open_Workbook_Dialog() 

Dim my_FileName As Variant 
Dim my_Workbook As Workbook 

    MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file 

    my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection 

    If my_FileName <> False Then 
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName) 

    Call TestThis 

    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes 

    End If 
End Sub 

Public Sub Filter(my_Workbook As Workbook) 
    Dim rCountry As Range, helpCol As Range 
    Dim wb As Workbook 
    With my_Workbook.Sheets(1) '<--| refer to data worksheet 
    With .UsedRange 
     Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in 
    End With 

    With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A" 
      .Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column 
      Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row) 
      For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row) 
       .AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name 
       If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered... 
        Set wb = Application.Workbooks.Add '<--... add new Workbook 
         wb.SaveAs Filename:=rCountry.Value2 '<--... saves the workbook after the country 
          .SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1") 
           ActiveSheet.Name = rCountry.Value2 '<--... rename it 
          .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header 
          Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off 
          ActiveWindow.Zoom = 55 'Zooms out the window 
         Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column 
        wb.Close SaveChanges:=True '<--... saves and closes workbook 
       End If 
      Next 
     End With 
     .AutoFilterMode = False '<--| remove autofilter and show all rows back 
    End With 
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included) 
End Sub 

Public Sub TestThis() 
Dim wks As Worksheet 

Set wks = ActiveWorkbook.Sheets(1) 

With wks 
.AutoFilterMode = False 
.Range("A:K").AutoFilter Field:=11, Criteria1:="<>", Operator:=xlFilterValues 
.Range("A:C").SpecialCells(xlCellTypeBlanks).Interior.Color = 65535 
.AutoFilterMode = False 
End With 
End Sub 

Answer 1

你只需要給出完整路徑SaveAs方法：

wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2 '<--... saves the workbook after the country 

如果您鴕鳥政策給一個完整的路徑，而只是一個文件名， exel將文件保存在當前文件夾中，但使用完整路徑時，excel會將文件保存在該位置並顯示您指定的名稱。

Answer 2

變化

wb.SaveAs Filename:=rCountry.Value2 

到

wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2