将新创建的工作簿保存到特定文件夹

Posted 2023-05-07

【中文标题】将新创建的工作簿保存到特定文件夹

【英文标题】：Saving a newly created workbook to a specific folder

【发布时间】：2016-11-08 15:43:18

【问题描述】：

希望你能帮上忙。 我有一段代码。 本质上它的作用是，它打开一个对话框，允许用户选择一个 Excel 表，然后它转到国家列 (11) 过滤它，然后将该国家复制并粘贴到一个新工作簿中，命名新工作簿在该国家/地区重复下一个国家/地区的操作之后，它会保存并关闭每个工作簿。

我要更改的是这些新工作簿的保存位置。

目前，它们被保存在存储模板（拆分的原始工作簿）和宏的同一文件夹中。我希望现在将新创建的工作簿保存在其他地方。这里 C:\Users\CONNELLP\Desktop\Claire Macro\CRO 国家

任何帮助将不胜感激。

工作簿当前存储位置的图片

原始模板的图片

我的代码

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

【参考方案1】：

您只需提供SaveAs 方法的完整路径：

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

如果您不提供完整路径，而只是提供文件名，则 exel 会将文件保存在当前文件夹中，但使用完整路径时，excel 会将文件保存在您指定的位置并使用您指定的名称。

【讨论】：

为此干杯，它非常有帮助，并且给了我所需要的。

【参考方案2】：

改变

wb.SaveAs Filename:=rCountry.Value2 

到

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