VBA | Save Worksheet As

rachel06

Board Regular
Joined
Feb 3, 2016
Messages
174
Office Version
  1. 365
Platform
  1. Windows
Are you looking for something like, to Loop through each workbook in the folder and save it like filename: <"ABC XYZ 123 Somename Rate Sheet 2-7-2025"> when say for example values in

C7-"ABC"
C8-"XYZ"
C9-"123"
C21-"Somename"
F12-"2-7-2025"
 
Upvote 0
Kind of. I only want it to save the sheet named "Pharmacy Pricing" though, not the entire workbook.
 
Upvote 0
May be something like this,

Please change the folder path accordingly, [: "C:\Users\Sam Online\Documents\Pharmacy"], I created some files in the Parmacy folder, this code loops through all the files and save it using the naming convention where the formula results in [='PDF2'!C7&" "&'PDF2'!C8&"-"&'PDF2'!C9&" "&'PDF2'!C21&" Rate Sheet "&" "&TEXT('PDF2'!F12,"m-d-yyyy")], assuming this naming convention is availavle in every files.

VBA Code:
Sub SavePharmacyPricingWithPdf2Values()
    Dim wb As Workbook, wsP As Worksheet, ws2 As Worksheet
    Dim folderPath As String, newFileName As String, fullFilePath As String
    Dim c7$, c8$, c9$, c21$, f12$, timestamp$

    folderPath = "C:\Users\Sam Online\Documents\Pharmacy\"
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    For Each file In CreateObject("Scripting.FileSystemObject").GetFolder(folderPath).Files
        If file.Name Like "*.xlsx" And file.Name <> ThisWorkbook.Name Then
            On Error Resume Next
            Set wb = Workbooks.Open(folderPath & file.Name, ReadOnly:=False)
            Set wsP = wb.Sheets("Pharmacy Pricing")
            Set ws2 = wb.Sheets("Pdf2")
            On Error GoTo 0
            
            If Not wsP Is Nothing And Not ws2 Is Nothing Then
                c7 = SafeTrim(ws2, "C7")
                c8 = SafeTrim(ws2, "C8")
                c9 = SafeTrim(ws2, "C9")
                c21 = SafeTrim(ws2, "C21")
                f12 = SafeTrim(ws2, "F12")
                
                newFileName = Left(file.Name, InStrRev(file.Name, ".") - 1) & "_" & c7 & "_" & c8 & "_" & c9 & "_" & c21 & "_" & f12 & ".xlsx"
                newFileName = Left(Replace(newFileName, "/", "_"), 255)
                fullFilePath = folderPath & newFileName

                If Dir(fullFilePath) <> "" Then
                    If MsgBox("File exists. Replace?", vbYesNoCancel + vbExclamation, "File Exists") = vbNo Then
                        newFileName = Left(newFileName, Len(newFileName) - 5) & "_" & Format(Now, "yyyy-mm-dd_HH-MM-SS") & ".xlsx"
                        fullFilePath = folderPath & newFileName
                    ElseIf MsgBox("File exists. Replace?", vbYesNoCancel + vbExclamation, "File Exists") = vbCancel Then
                        wb.Close False: Exit Sub
                    End If
                End If

                On Error Resume Next
                wsP.Copy
                If Err.Number = 0 Then
                    ActiveWorkbook.SaveAs fullFilePath, FileFormat:=xlOpenXMLWorkbook
                    ActiveWorkbook.Close False
                End If
                On Error GoTo 0
            End If
            wb.Close False
        End If
    Next file

    MsgBox "All Pharmacy Pricing sheets saved!", vbInformation, "Completed"
End Sub

Function SafeTrim(ws As Worksheet, cellRef As String) As String
    On Error Resume Next
    SafeTrim = Trim(ws.Range(cellRef).Value)
    If Err.Number <> 0 Then SafeTrim = ""
    On Error GoTo 0
End Function

Some sample files in the Pharmacy folder: Code is loaded in "\XYZ" file.

1739148234982.png
 
Upvote 0
Solution
Amazing, thank you! It's so fast too!!

Is there a way to add a message box to input the folder location (or just have Windows Explorer pop up to select the location?)
 
Upvote 0
Also sometimes I get a message about external links. Is there something I can put in there to just automatically say "don't update" to that?
 
Last edited:
Upvote 0
Amazing, thank you! It's so fast too!!

Is there a way to add a message box to input the folder location (or just have Windows Explorer pop up to select the location?)
* Or even just a cell reference to paste the path into
 
Upvote 0
Also sometimes I get a message about external links. Is there something I can put in there to just automatically say "don't update" to that?
Oh yeah, I guess the file naming convention formula should be in your [Pharmacy Pricing] sheet and that is the external link
 
Upvote 0
Oh yeah, I guess the file naming convention formula should be in your [Pharmacy Pricing] sheet and that is the external link
No it's not that. It's sometimes the workbooks I get (that we're extracting one sheet from and saving) have external links in them. Wondering if there's a way to just have the macro keeping going if it gets that and not update?

Also, I got the part figured out on how to just have a cell reference the path instead of having it coded in the script.
 
Upvote 0
May be you can try this,

1, Select the folder to locate the files
2, Select the folder where you want to save the processed files
3, AND(Processed files wont replace the existing files to prevent data loss)
VBA Code:
Sub SavePharmacyPricingWithPdf2Valueslatest()
    Dim wb As Workbook, newWb As Workbook
    Dim wsP As Worksheet, ws2 As Worksheet
    Dim sourceFolder As String, saveFolder As String
    Dim newFileName As String, fullFilePath As String
    Dim c7$, c8$, c9$, c21$, f12$
    Dim folderDialog As FileDialog
    Dim file As Object
    Dim rng As Range
    Dim fileCounter As Integer

    sourceFolder = GetFolder("Select Folder Containing Pharmacy Pricing Files")
    If sourceFolder = "" Then Exit Sub
    saveFolder = GetFolder("Select Folder to Save Processed Files")
    If saveFolder = "" Then Exit Sub

    For Each file In CreateObject("Scripting.FileSystemObject").GetFolder(sourceFolder).Files
        If file.Name Like "*.xlsx" And file.Name <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(sourceFolder & file.Name, ReadOnly:=False)
            Set wsP = Nothing: Set ws2 = Nothing
            On Error Resume Next
            Set wsP = wb.Sheets("Pharmacy Pricing")
            Set ws2 = wb.Sheets("Pdf2")
            On Error GoTo 0

            If wsP Is Nothing Then GoTo CloseAndNext
            Set rng = wsP.UsedRange
            If rng Is Nothing Or Application.WorksheetFunction.CountA(rng) = 0 Then GoTo CloseAndNext

            c7 = SafeTrim(ws2, "C7"): c8 = SafeTrim(ws2, "C8"): c9 = SafeTrim(ws2, "C9")
            c21 = SafeTrim(ws2, "C21"): f12 = SafeTrim(ws2, "F12")

            newFileName = Left(file.Name, InStrRev(file.Name, ".") - 1) & _
                          "_" & c7 & "_" & c8 & "_" & c9 & "_" & c21 & "_" & f12 & ".xlsx"
            newFileName = Left(Replace(newFileName, "/", "-"), 255)
            fullFilePath = saveFolder & newFileName

            fileCounter = 1
            While Dir(fullFilePath) <> ""
                newFileName = Left(newFileName, Len(newFileName) - 5) & "_" & fileCounter & ".xlsx"
                fullFilePath = saveFolder & newFileName
                fileCounter = fileCounter + 1
            Wend

            Set newWb = Workbooks.Add
            wsP.Copy After:=newWb.Sheets(newWb.Sheets.Count)
            newWb.Sheets(newWb.Sheets.Count).Name = "Pharmacy Pricing"
            newWb.SaveAs fullFilePath, FileFormat:=xlOpenXMLWorkbook
            newWb.Close False

CloseAndNext:
            wb.Close False
        End If
    Next file

    ThisWorkbook.Save
    ThisWorkbook.Close
End Sub

Function GetFolder(prompt As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = prompt
        If .Show = -1 Then GetFolder = .SelectedItems(1) & "\"
    End With
End Function

Function SafeTrim(ws As Worksheet, cellRef As String) As String
    On Error Resume Next
    SafeTrim = Trim(ws.Range(cellRef).Value)
    If Err.Number <> 0 Then SafeTrim = "NA"
    On Error GoTo 0
End Function
 
Upvote 0

Forum statistics

Threads
1,226,771
Messages
6,192,919
Members
453,767
Latest member
922aloose

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top