VBA | Save Worksheet As

[rachel06]

Hi!

I have a workbook that has sheets "Pharmacy Pricing" and "PDF2"

I'm trying to get a macro to work that'll "Save As" the "Pharmacy Pricing" sheet, using the naming convention this formula results in:

='PDF2'!C7&" "&'PDF2'!C8&"-"&'PDF2'!C9&" "&'PDF2'!C21&" Rate Sheet "&" "&TEXT('PDF2'!F12,"m-d-yyyy")

If I could do this as a loop for several worksheets in a folder, even better!

I've been looking up ways to accomplish this, but I'm just getting very confused.

Thanks so much!

Rachel

 

[Sam_D_Ben]

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"

 

[rachel06]

Kind of. I only want it to save the sheet named "Pharmacy Pricing" though, not the entire workbook.

 

[Sam_D_Ben]

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.

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.

 

[rachel06]

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

 

[rachel06]

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?

 

[rachel06]

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

 

[Sam_D_Ben]

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

 

[rachel06]

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.

 

[Sam_D_Ben]

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)

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