Saving a file multiple times using each choice in a drop down list

[Francoise White]

Hi

How can I build a macro to select each choice in a drop down list individually and, after each selection, save the file with the name of the drop down cell selected ? After saving each file, I'd also like to break the links in the saved files but not the main file.

So, for example, the main file has 10 sheets pulling data from other locations based on the name of a branch in cell a1 in sheet 1. Cell a1 is a validated data cell referring to the list of the 50 branch names further down in the same sheet.

All help warmly welcomed.

 

[pbornemeier]

Change the kine of code in post #6 from:
ActiveWorkbook.Sheets.Copy 'Copy all worksheets to new workbook
to
ActiveSheet.Copy 'Copy active sheet to new workbook

 

[AboveBeyond]

That works for saving a the worksheet but I"m getting a popup error because the validation list is on another tab. Is there a way to hardcode the data so the validation dropdown list and formulas aren't looking at non-existing tabs? Thanks!

 

[pbornemeier]

Option Explicit
 
Sub ChangeA1CreateNewFile()
    ' Create a named range for the list source of the data validation list
    ' for cell A1.  This code expects the name to be "A1DDListSource"
    ' Code assumes that the validation cell is on worksheet "Sheet1"
 
    Dim rngCell As Range
    Dim sWorksheetName As String
    Dim sNewWorkbookName As String
 
    sWorksheetName = "Sheet1"
 
    For Each rngCell In Range("A1DDListSource")
        Worksheets(sWorksheetName).Range("A1").Value = rngCell.Value
        sNewWorkbookName = rngCell.Value
        ActiveSheet.Copy 'Copy all worksheets to new workbook
        With ActiveSheet.Cells
            .Copy
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
        End With
    Application.CutCopyMode = False
        BreakLinks 'Break all links in the new workbook
        'RemoveNames 'Optional - uncomment to remove names from new workbook
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sNewWorkbookName
        ActiveWorkbook.Close
    Next
 
End Sub
 
Private Sub BreakLinks()
    'Breaks links to other workbooks from the active workbook
 
    Dim vLinks As Variant
    Dim vLink As Variant
    vLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
    If Not IsEmpty(vLinks) Then
        For Each vLink In vLinks
            ActiveWorkbook.BreakLink Name:=vLink, Type:=xlLinkTypeExcelLinks
        Next
    End If
 
End Sub
 
Private Sub RemoveNames()
    Dim nm As Name
 
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next
 
End Sub

 

[rohitcool58]

hi,
i want to have a macro which can pick a excel file from a location and then save it multiple times with different names.

 

[pbornemeier]

Try this:

Option Explicit

Sub MultipleRename()

    Dim sFilePath As String
    Dim sFileNameExt As String
    Dim sFileName As String
    Dim sFileExt As String
    Dim vInput As Variant
    Dim lFinalPathSepLoc As Long
    Dim sNewPathNameExt As String
    Dim sCopied
    Dim sFailed
    Dim aryNewNames() As Variant
    Dim lNewNameCount As Long
    Dim lX As Long
    Dim lY As Long
    
    
    'Create New Names (10 random, lowercase letters)
    lNewNameCount = 10
    For lX = 1 To lNewNameCount
        For lY = 1 To 10
            sFileName = sFileName & Chr(Int((122 - 97 + 1) * Rnd + 97))
        Next
        ReDim Preserve aryNewNames(1 To lX)
        aryNewNames(lX) = sFileName
        sFileName = vbNullString
    Next
        
    'Set location that the diretory search should start
    If ThisWorkbook.Path = vbNullString Then
        ChDir "C:\"
        ChDrive "C:\"
    Else
        ChDrive ThisWorkbook.Path
        ChDir ThisWorkbook.Path
    End If
    
    'Open the standard Open dialog box at the specified location
    vInput = Application.GetOpenFilename("All Files (*.*), *.*", _
        , "Select a File to Multiply Rename", "Select")
    If vInput = False Then GoTo End_Sub
    
    lFinalPathSepLoc = InStrRev(vInput, Application.PathSeparator)
    sFilePath = CStr(Left(vInput, lFinalPathSepLoc))
    sFileNameExt = CStr(Mid(vInput, lFinalPathSepLoc + 1))
    sFileName = Left(sFileNameExt, InStr(sFileNameExt, ".") - 1)
    sFileExt = Mid(sFileNameExt, InStr(sFileNameExt, ".") + 1)

    'Copy file multiple times
    For lX = LBound(aryNewNames) To UBound(aryNewNames)
        sNewPathNameExt = sFilePath & aryNewNames(lX) & "." & sFileExt
        
        'Will fail if source file is open or if destination file exists
        If Dir(sNewPathNameExt) = vbNullString Then
            FileCopy CStr(vInput), sNewPathNameExt
            sCopied = sCopied & "   " & sNewPathNameExt & vbLf
        Else
            sFailed = sFailed & "   " & sNewPathNameExt & vbLf
        End If
    Next
    
    If sCopied = vbNullString Then sCopied = "   <none>"
    If sFailed = vbNullString Then sFailed = "   <none>"
    
    MsgBox CStr(vInput) & vbLf & vbLf & _
        "Copied to:" & vbLf & sCopied & vbLf & vbLf & _
        "Could not be copied to:" & vbLf & sFailed, , "Copy Report"

End_Sub:
    
End Sub

 

[rohitcool58]

Try this:

Option Explicit

Sub MultipleRename()

    Dim sFilePath As String
    Dim sFileNameExt As String
    Dim sFileName As String
    Dim sFileExt As String
    Dim vInput As Variant
    Dim lFinalPathSepLoc As Long
    Dim sNewPathNameExt As String
    Dim sCopied
    Dim sFailed
    Dim aryNewNames() As Variant
    Dim lNewNameCount As Long
    Dim lX As Long
    Dim lY As Long
    
    
    'Create New Names (10 random, lowercase letters)
    lNewNameCount = 10
    For lX = 1 To lNewNameCount
        For lY = 1 To 10
            sFileName = sFileName & Chr(Int((122 - 97 + 1) * Rnd + 97))
        Next
        ReDim Preserve aryNewNames(1 To lX)
        aryNewNames(lX) = sFileName
        sFileName = vbNullString
    Next
        
    'Set location that the diretory search should start
    If ThisWorkbook.Path = vbNullString Then
        ChDir "C:\"
        ChDrive "C:\"
    Else
        ChDrive ThisWorkbook.Path
        ChDir ThisWorkbook.Path
    End If
    
    'Open the standard Open dialog box at the specified location
    vInput = Application.GetOpenFilename("All Files (*.*), *.*", _
        , "Select a File to Multiply Rename", "Select")
    If vInput = False Then GoTo End_Sub
    
    lFinalPathSepLoc = InStrRev(vInput, Application.PathSeparator)
    sFilePath = CStr(Left(vInput, lFinalPathSepLoc))
    sFileNameExt = CStr(Mid(vInput, lFinalPathSepLoc + 1))
    sFileName = Left(sFileNameExt, InStr(sFileNameExt, ".") - 1)
    sFileExt = Mid(sFileNameExt, InStr(sFileNameExt, ".") + 1)

    'Copy file multiple times
    For lX = LBound(aryNewNames) To UBound(aryNewNames)
        sNewPathNameExt = sFilePath & aryNewNames(lX) & "." & sFileExt
        
        'Will fail if source file is open or if destination file exists
        If Dir(sNewPathNameExt) = vbNullString Then
            FileCopy CStr(vInput), sNewPathNameExt
            sCopied = sCopied & "   " & sNewPathNameExt & vbLf
        Else
            sFailed = sFailed & "   " & sNewPathNameExt & vbLf
        End If
    Next
    
    If sCopied = vbNullString Then sCopied = "   <NONE>"
    If sFailed = vbNullString Then sFailed = "   <NONE>"
    
    MsgBox CStr(vInput) & vbLf & vbLf & _
        "Copied to:" & vbLf & sCopied & vbLf & vbLf & _
        "Could not be copied to:" & vbLf & sFailed, , "Copy Report"

End_Sub:
    
End Sub

hi,
but i have one doubt. from where it will tak the names

 

[pbornemeier]

The first part of the code generates 10 random names and puts them in the aryNewNames array.
If that does not work for you, how do you want to define the new names?

 

[rohitcool58]

The first part of the code generates 10 random names and puts them in the aryNewNames array.
If that does not work for you, how do you want to define the new names?

I will have the specific names in one excel sheet, i want the files to be renamed with that names only

 

[pbornemeier]

Try this. Be sure to update the code to shows where the new names are in your workbook:

Option Explicit

Sub MultipleRename()

    Dim sFilePath As String
    Dim sFileNameExt As String
    Dim sFileName As String
    Dim sFileExt As String
    Dim vInput As Variant
    Dim lFinalPathSepLoc As Long
    Dim sNewPathNameExt As String
    Dim sCopied
    Dim sFailed
    Dim aryNewNames() As Variant
    Dim lX As Long
    Dim lLastNameRow As Long
    Dim sFileNameWorksheetName As String
    Dim sFileNameRange As String
    
    'Edit the next 2 rows to show the location of the new file names:
    sFileNameWorksheetName = "Sheet1"
    sFileNameRange = "A1:A5"
    
    'Copy names from specified worksheet & range
    For lX = 1 To Range(sFileNameRange).Cells.Count
        ReDim Preserve aryNewNames(1 To lX)
        aryNewNames(lX) = Worksheets(sFileNameWorksheetName).Range(sFileNameRange).Cells(1)
        sFileName = vbNullString
    Next
        
    'Set location that the diretory search should start
    If ThisWorkbook.Path = vbNullString Then
        ChDir "C:\"
        ChDrive "C:\"
    Else
        ChDrive ThisWorkbook.Path
        ChDir ThisWorkbook.Path
    End If
    
    'Open the standard Open dialog box at the specified location
    vInput = Application.GetOpenFilename("All Files (*.*), *.*", _
        , "Select a File to Multiply Rename", "Select")
    If vInput = False Then GoTo End_Sub
    
    lFinalPathSepLoc = InStrRev(vInput, Application.PathSeparator)
    sFilePath = CStr(Left(vInput, lFinalPathSepLoc))
    sFileNameExt = CStr(Mid(vInput, lFinalPathSepLoc + 1))
    sFileName = Left(sFileNameExt, InStr(sFileNameExt, ".") - 1)
    sFileExt = Mid(sFileNameExt, InStr(sFileNameExt, ".") + 1)

    'Copy file multiple times
    For lX = LBound(aryNewNames) To UBound(aryNewNames)
        sNewPathNameExt = sFilePath & aryNewNames(lX) & "." & sFileExt
        
        'Will fail if source file is open, if destination file exists, or if invalid filename
        If Dir(sNewPathNameExt) = vbNullString Then
            On Error Resume Next
            FileCopy CStr(vInput), sNewPathNameExt
            On Error GoTo 0
            sCopied = sCopied & "   " & sNewPathNameExt & vbLf
        Else
            sFailed = sFailed & "   " & sNewPathNameExt & vbLf
        End If
    Next
    
    If sCopied = vbNullString Then sCopied = "   "
    If sFailed = vbNullString Then sFailed = "   "
    
    MsgBox CStr(vInput) & vbLf & vbLf & _
        "Copied to:" & vbLf & sCopied & vbLf & vbLf & _
        "Could not be copied to:" & vbLf & sFailed, , "Copy Report"

End_Sub:
    
End Sub

 

[rbenkese]

Hi Phil,

Thank you for providing this code -- it is super helpful. The only problem I have had when exercising this code is that all of the individual files that were saved have different formatting than the original Excel 2013 file format. Is there a way to preserve the formatting when going through this process?

Again,
Thank you very much-- it will be a HUGE time saver for me.

Create a named range for the list source of the data validation list for cell A1. This code expects the name to be A1DDListSource. If it is likely that the list will change, I suggest you use a dynamic range instead of a hard coded range for the named range.

Code assumes that the validation cell is on worksheet "Sheet1" if that is not the case, make appropriate changes to the sWorksheetName = "Sheet1" line.

There is no error checking for invalid filename characters in the data validation list. They include: \ / : * ? " < > |

The SaveAs line could have some complications. For more info see: http://www.rondebruin.nl/saveas.htm

Lots of good info at his webpage, including info on mailing workbooks/worksheets from using Excel code: Mail from Excel example pages

Option Explicit
 
Sub ChangeA1CreateNewFile()
    ' Create a named range for the list source of the data validation list
    ' for cell A1.  This code expects the name to be "A1DDListSource"
    ' Code assumes that the validation cell is on worksheet "Sheet1"
 
    Dim rngCell As Range
    Dim sWorksheetName As String
    Dim sNewWorkbookName As String
 
    sWorksheetName = "Sheet1"
 
    For Each rngCell In Range("A1DDListSource")
        Worksheets(sWorksheetName).Range("A1").Value = rngCell.Value
        sNewWorkbookName = rngCell.Value
        ActiveWorkbook.Sheets.Copy 'Copy all worksheets to new workbook
        BreakLinks 'Break all links in the new workbook
        'RemoveNames 'Optional - uncomment to remove names from new workbook
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sNewWorkbookName
        ActiveWorkbook.Close
    Next
 
End Sub
 
Private Sub BreakLinks()
    'Breaks links to other workbooks from the active workbook
 
    Dim vLinks As Variant
    Dim vLink As Variant
    vLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
    If Not IsEmpty(vLinks) Then
        For Each vLink In vLinks
            ActiveWorkbook.BreakLink Name:=vLink, Type:=xlLinkTypeExcelLinks
        Next
    End If
 
End Sub
 
Private Sub RemoveNames()
    Dim nm As Name
 
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next
 
End Sub