Saving a newly created workbook to a specific folder

[Conell8383]

Hi all. I hope you can help.
I have a piece of code.
Essentially what it does is, it opens a dialog box that allows a user to select an excel sheet, then it goes out to the country column (11) filters it, then copies and pastes that country into a new workbook, names the new workbook after that country then repeats the action for the next country, then it saves and closes each Workbook.


What I would like to change is where these new workbooks are being saved.

Currently they are being saved in the same folder where the Template (The Original workbook that gets split) and the Macro are stored. I would like the newly created Workbooks to be now saved somewhere else. Here C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries

Any help would be greatly appreciated.

Pic of where the Workbooks are currently stored

My Code is Below

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
                         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

 

[RCBricker]

Hi all. I hope you can help.
I have a piece of code.
Essentially what it does is, it opens a dialog box that allows a user to select an excel sheet, then it goes out to the country column (11) filters it, then copies and pastes that country into a new workbook, names the new workbook after that country then repeats the action for the next country, then it saves and closes each Workbook.


What I would like to change is where these new workbooks are being saved.

Currently they are being saved in the same folder where the Template (The Original workbook that gets split) and the Macro are stored. I would like the newly created Workbooks to be now saved somewhere else. Here C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries

Any help would be greatly appreciated.

Pic of where the Workbooks are currently stored

My Code is Below

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
                         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

just change the following code:

wb.SaveAs Filename:=rCountry.Value2

to something like:

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