Save to different folder according to cell value (adjust my macro)

[Lux Aeterna]

Hello precious forumers!!

I've got a macro that saves as PDF. Now I'd like to adjust it in order to save to a different folder according to the value of cell F7 on sheet Test pap.
The path I use at the moment is C:\Users\pc50\Desktop\New results\

Thank you in advance!

Sub ÁðïèÞêåõóç()
    Application.ScreenUpdating = False
    Dim ID As Range, sup As String, sID As String
    If Sheets("Test pap").Range("U2") = "" Then
        MsgBox ("Ôï ID äåí ìðïñåß íá åßíáé êåíü.")
        Sheets("Test pap").Range("U2").Select
        Exit Sub
    End If
    If Sheets("Test pap").Range("U3") = "" Then
        MsgBox ("Ôï êßôñéíï êåëß äåí ìðïñåß íá åßíáé êåíü.")
        Sheets("Test pap").Range("U3").Select
        Exit Sub
    End If
    Set ID = Sheets("List" & Range("Y2").Value).Range("A:A").Find(Sheets("Test pap").Range("U2").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not ID Is Nothing Then
        If ID.Offset(, 1) <> "" Then
            If MsgBox("Ôï áðïôÝëåóìá Ý÷åé Þäç äïèåß áðü " & ID.Offset(, 37) & "." & Chr(10) _
                & "Èåò ïðùóäÞðïôå íá ôï áíôéêáôáóôÞóåéò;", vbYesNo + vbDefaultButton2) = vbYes Then
                ID.Offset(, 1) = Sheets("Test pap").Range("AB9")
                ID.Offset(, 38) = Sheets("Test pap").Range("A45")
                ID.Offset(, 39) = Sheets("Test pap").Range("A46")
            Else
                Sheets("Test pap").Range("U2:X3").ClearContents
                Sheets("Test pap").Range("U2:X2").Select
                MsgBox ("Âåâáéþóïõ üôé ôá óôïé÷åßá ðïõ êáôá÷þñçóåò áöïñïýí ôï óùóôü äåßãìá! Áí ü÷é, ðÜôá êáèáñéóìü!")
                Exit Sub
            End If
        Else
            ID.Offset(, 1) = Sheets("Test pap").Range("AB9")
            ID.Offset(, 38) = Sheets("Test pap").Range("A45")
            ID.Offset(, 39) = Sheets("Test pap").Range("A46")
        End If
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\pc50\Desktop\New results\" & Range("AH1").Value _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Else
        MsgBox ("Ôï ID " & Sheets("Test pap").Range("U2") & " äåí õðÜñ÷åé óôç ëßóôá ôùí ñáíôåâïý " & Sheets("Test pap").Range("Y2") & "." & Chr(10) & "¸ëåãîå üôé Ýâáëåò ôï óùóôü Ýôïò êáé ôï óùóôü ID.")
        Sheets("Test pap").Range("U2:X3").ClearContents
        Sheets("Test pap").Range("U2:X2").Select
        Exit Sub
    End If
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

 

[HaHoBe]

Hi Lux Aeterna,

I altered the code to hold a With-clause for the worksheet (mind the dots as they refer to the sheet) and a second check for the existence or creation of folders. If you decide to use more subfolders I would prefer to use a loop instead of adding more checks.

Sub ÁðïèÞêåõóç()
'https://www.mrexcel.com/board/threads/save-to-different-folder-according-to-cell-value-adjust-my-macro.1229933/
  Dim ID As Range, sup As String, sID As String
  Dim strPath As String
  
  Const cstrMyBase As String = "C:\Users\pc50\Desktop\New results\"
  
  Application.ScreenUpdating = False
  
  With Worksheets("Test pap")
    If .Range("U2") = "" Then
      MsgBox ("Ôï ID äåí ìðïñåß íá åßíáé êåíü.")
      .Range("U2").Select
      Exit Sub
    End If
    If .Range("U3") = "" Then
      MsgBox ("Ôï êßôñéíï êåëß äåí ìðïñåß íá åßíáé êåíü.")
      .Range("U3").Select
      Exit Sub
    End If
    Set ID = Sheets("List" & Range("Y2").Value).Range("A:A").Find(.Range("U2").Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not ID Is Nothing Then
      If ID.Offset(, 1) <> "" Then
        If MsgBox("Ôï áðïôÝëåóìá Ý÷åé Þäç äïèåß áðü " & ID.Offset(, 37) & "." & Chr(10) _
            & "Èåò ïðùóäÞðïôå íá ôï áíôéêáôáóôÞóåéò;", vbYesNo + vbDefaultButton2) = vbYes Then
          ID.Offset(, 1) = .Range("AB9")
          ID.Offset(, 38) = .Range("A45")
          ID.Offset(, 39) = .Range("A46")
        Else
          .Range("U2:X3").ClearContents
          .Range("U2:X2").Select
          MsgBox ("Âåâáéþóïõ üôé ôá óôïé÷åßá ðïõ êáôá÷þñçóåò áöïñïýí ôï óùóôü äåßãìá! Áí ü÷é, ðÜôá êáèáñéóìü!")
          Exit Sub
        End If
      Else
        ID.Offset(, 1) = .Range("AB9")
        ID.Offset(, 38) = .Range("A45")
        ID.Offset(, 39) = .Range("A46")
      End If
      '/// new check for range added
      strPath = cstrMyBase & .Range("Y2").Value
      If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
      End If
      '/// altered code for the second check
      strPath = strPath & Application.PathSeparator & .Range("F7").Value
      If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
      End If
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
         Filename:=strPath & "\" & Range("AH1").Value, _
         Quality:=xlQualityStandard, _
         IncludeDocProperties:=True, _
         IgnorePrintAreas:=False, _
         OpenAfterPublish:=True
    Else
      MsgBox ("Ôï ID " & .Range("U2") & " äåí õðÜñ÷åé óôç ëßóôá ôùí ñáíôåâïý " & .Range("Y2") & "." & Chr(10) & _
          "¸ëåãîå üôé Ýâáëåò ôï óùóôü Ýôïò êáé ôï óùóôü ID.")
      .Range("U2:X3").ClearContents
      .Range("U2:X2").Select
      Exit Sub
    End If
  End With
  ActiveWorkbook.Save
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[Lux Aeterna]

I got a debug error, but I wasn't able to reproduce it. It might have been on my side. Macro works perfectly!

I won't have to add any other subfolders, but I might need to swap F7 and Y2 folders. I guess I'll only have to change the two cell values.

      '/// new check for range added
      strPath = cstrMyBase & .Range("Y2").Value
      If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
      End If
      '/// altered code for the second check
      strPath = strPath & Application.PathSeparator & .Range("F7").Value
      If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
      End If

 

[HaHoBe]

Hi Lux Aeterna,

but I might need to swap F7 and Y2 folders. I guess I'll only have to change the two cell values.

Exactly.

Holger