将新创建的工作簿保存到特定文件夹
问题描述:
我希望你能提供帮助。 我有一段代码。 本质上它所做的就是打开一个对话框,允许用户选择一个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
答
你只需要给出完整路径SaveAs
方法:
wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2 '<--... saves the workbook after the country
如果您鸵鸟政策给一个完整的路径,而只是一个文件名, exel将文件保存在当前文件夹中,但使用完整路径时,excel会将文件保存在该位置并显示您指定的名称。
答
变化
wb.SaveAs Filename:=rCountry.Value2
到
wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2
为此干杯这是非常有益的,并给了我确切的需要。 –
我其实早点回复4秒!但那就是生活...... – user3598756