Copy files from sub-folders to other folder

Lux Aeterna

Board Regular
Joined
Aug 27, 2015
Messages
205
Office Version
  1. 2019
Platform
  1. Windows
Hey everyone!

Not sure if this is the right place to ask.

I've got an excel VBA code that saves excel file as PDF to specific folder and sub-folder according to cell values.

The path is C:\Users\pc50\Desktop\New results\F7_value\Y2_value\
The folder New results and its sub-folders are auto synced to google drive. However I need to have two more copies of those PDFs, one locally (without syncing to google drive) and one on the network. Those copies should not be in separate folders and sub-folders. Just the PDFs alone.

Thanks in advance
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
You already create the PDF file in that folder above, so you can simply use the FileCopy statement to copy that PDF file from that directory above to the other folders. (Since you didn't provide any existing code, the following is just an assumption that your existing code is storing path and file name in variables - which is the ideal way):

VBA Code:
Sub UnknownMacro()

' ... Existing code

strFolder = "C:\Users\pc50\Desktop\New results\" & Range("F7").Value & "\" & Range("Y2").Value & "\"
strFileName = "FileName.pdf"

' ... More existing code to save the PDF file and maybe more stuff

' Suggested addition to copy the same file to other places
strOtherFolder1 = "C:\SomeOtherPlace\"
strOtherFolder2 = "C:\SomeAnotherPlace\"

FileCopy strFolder & strFileName, strOtherFolder1 & strFileName
FileCopy strFolder & strFileName, strOtherFolder2 & strFileName

End Sub
 
Upvote 0
The VBA code I use is this one

VBA Code:
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

I have to add your lines to my code, right?

The file name comes from cell AH1, which is a combination of two other cells and it's unique every time. So I guess it is in variables, as you said.

However I forgot to mention that when PDF is printed, we add a signature to it and then we save it. So it's the signed file that I need to copy to the two other locations, not the original one. :rolleyes:

I was wondering if there's some kind of script, not necessarily in excel, that does the job.

Edit:

Our procedure is:
- Type data in the sheet
- Use macro to save as PDF
- Sign the PFD and close it
- Use another macro to clear the data from the sheet.

Maybe I could add your code in the latter macro.

VBA Code:
Sub Êáèáñéóìüò()
'
' Êáèáñéóìüò ÌáêñïåíôïëÞ
'
' Óõíôüìåõóç ðëçêôñïëïãßïõ: Ctrl+ê
'
    Range("U2:X2").Select
    Selection.ClearContents
    Range("U3:X3").Select
    Selection.ClearContents
    Range("Y2").Select
    ActiveCell.FormulaR1C1 = Year(Now())
    Range("H14:K17").Select
    Selection.ClearContents
    Range("T14:W15").Select
    Selection.ClearContents
    Range("T17:W17").Select
    Selection.ClearContents
    Range("G21:J23").Select
    Selection.ClearContents
    Range("G25:J25").Select
    Selection.ClearContents
    Range("U21:X25").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=6
    Range("D28").Select
    Selection.ClearContents
    Range("L28").Select
    Selection.ClearContents
    Range("W28").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("C33:C35").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("V33:V34").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=12
    Range("V37").Select
    Selection.ClearContents
    Range("I37").Select
    Selection.ClearContents
    Range("U40:U41").Select
    Selection.ClearContents
    Range("H40:H41").Select
    Selection.ClearContents
    Range("E42:K42").Select
    Selection.ClearContents
    Range("A46:X47").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=-27
    Range("H14:K14").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H15:K15").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H16:K16").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("T14:W14").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("T15:W15").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("M17:S17").Select
    ActiveCell.FormulaR1C1 = "¢ëëá"
    Range("T17:W17").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("M18:S18").Select
    ActiveCell.FormulaR1C1 = "¢ëëá"
    Range("T18:W18").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H17:K17").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G18").Select
    Selection.ClearContents
    Range("I18").Select
    Selection.ClearContents
    Range("K18").Select
    Selection.ClearContents
    Range("G21:J21").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G22:J22").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G23:J23").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G25:J25").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U21:X21").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U22:X22").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U23:X23").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U24:X24").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U25:X25").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("L28").Select
    Selection.ClearContents
    Range("W28").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("D28").Select
    ActiveCell.FormulaR1C1 = "×"
    Range("D29").Select
    ActiveWindow.SmallScroll Down:=6
    Range("C33:C35").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("V33:V34").Select
    Selection.ClearContents
    Range("V37").Select
    Selection.ClearContents
    Range("I37").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=9
    Range("H40:H41").Select
    Selection.ClearContents
    Range("U40:U41").Select
    Selection.ClearContents
    Range("E42:K42").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("A46:X47").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=-21
    Range("AA2:AA8").Select
    Selection.ClearContents
    Range("U2:X2").Select
    Selection.ClearContents
End Sub
 
Last edited:
Upvote 0
After the ActiveSheet.ExportAsFixedFormat code line, you can use the FileCopy statement as I explained.

VBA Code:
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
         Filename:=strPath & "\" & Range("AH1").Value, _
         Quality:=xlQualityStandard, _
         IncludeDocProperties:=True, _
         IgnorePrintAreas:=False, _
         OpenAfterPublish:=True

     FileCopy strPath & "\" & Range("AH1").Value, "C:\SomeOtherPlace\" & Range("AH1").Value

Note: If Range("AH1") doesn't contain the .pdf extension, then you need to add that too in both source and target arguments: Range("AH1").Value & ".pdf"
 
Upvote 0
After the ActiveSheet.ExportAsFixedFormat code line, you can use the FileCopy statement as I explained.

VBA Code:
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
         Filename:=strPath & "\" & Range("AH1").Value, _
         Quality:=xlQualityStandard, _
         IncludeDocProperties:=True, _
         IgnorePrintAreas:=False, _
         OpenAfterPublish:=True

     FileCopy strPath & "\" & Range("AH1").Value, "C:\SomeOtherPlace\" & Range("AH1").Value

Note: If Range("AH1") doesn't contain the .pdf extension, then you need to add that too in both source and target arguments: Range("AH1").Value & ".pdf"

Thanks for explaining!

No, AH1 doesn't contain .pdf extension.

Can you please check the edit I made to my message?
 
Upvote 0
Hey, @smozgur !

I tried to use your code but I'm probably making some mistake.

I'll give the full details for you to help if you can.

The original save folder is C:\Users\pc50\Desktop\New results\F7_value\Y2_value\

The macro I use to save there is this one, in case you need it.

VBA Code:
Sub Αποθήκευση()
  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

For practical reasons, the "copy file" addition needs to be in a different macro. Namely, this one

VBA Code:
Sub Καθαρισμός()
'
' Καθαρισμός Μακροεντολή
'
' Συντόμευση πληκτρολογίου: Ctrl+κ
'

    Range("U2:X2").Select
    Selection.ClearContents
    Range("U3:X3").Select
    Selection.ClearContents
    Range("Y2").Select
    ActiveCell.FormulaR1C1 = Year(Now())
    Range("H14:K17").Select
    Selection.ClearContents
    Range("T14:W15").Select
    Selection.ClearContents
    Range("T17:W17").Select
    Selection.ClearContents
    Range("G21:J23").Select
    Selection.ClearContents
    Range("G25:J25").Select
    Selection.ClearContents
    Range("U21:X25").Select
    Selection.ClearContents
    Range("D28").Select
    Selection.ClearContents
    Range("L28").Select
    Selection.ClearContents
    Range("W28").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("C33:C35").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("V33:V34").Select
    Selection.ClearContents
    Range("V37").Select
    Selection.ClearContents
    Range("I37").Select
    Selection.ClearContents
    Range("U40:U41").Select
    Selection.ClearContents
    Range("H40:H41").Select
    Selection.ClearContents
    Range("E42:K42").Select
    Selection.ClearContents
    Range("A46:X47").Select
    Selection.ClearContents
    Range("H14:K14").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H15:K15").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H16:K16").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("T14:W14").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("T15:W15").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("M17:S17").Select
    ActiveCell.FormulaR1C1 = "Άλλα"
    Range("T17:W17").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("M18:S18").Select
    ActiveCell.FormulaR1C1 = "Άλλα"
    Range("T18:W18").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("H17:K17").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G18").Select
    Selection.ClearContents
    Range("I18").Select
    Selection.ClearContents
    Range("K18").Select
    Selection.ClearContents
    Range("G21:J21").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G22:J22").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G23:J23").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("G25:J25").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U21:X21").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U22:X22").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U23:X23").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U24:X24").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("U25:X25").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("L28").Select
    Selection.ClearContents
    Range("W28").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("D28").Select
    ActiveCell.FormulaR1C1 = "×"
    Range("D29").Select
    Range("C33:C35").Select
    Selection.ClearContents
    Range("K30").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("W30").Select
    Selection.ClearContents
    Range("G33:G35").Select
    Selection.ClearContents
    Range("V33:V34").Select
    Selection.ClearContents
    Range("V37").Select
    Selection.ClearContents
    Range("I37").Select
    Selection.ClearContents
    Range("H40:H41").Select
    Selection.ClearContents
    Range("U40:U41").Select
    Selection.ClearContents
    Range("E42:K42").Select
    ActiveCell.FormulaR1C1 = "- - - - - - -"
    Range("A46:X47").Select
    Selection.ClearContents
    Range("AA2:AA8").Select
    Selection.ClearContents
    Range("U2:X2").Select
    Selection.ClearContents
End Sub

Your addition has to be at the beginning of the macro, because at the end of it data from cells F7, Y2 and AH1 is cleared.

File name is C:\Users\pc50\Desktop\New results\F7_value\Y2_value\AH1_value.pdf (".pdf" is not included in AH1)

There will be two copy folders
The first one is C:\Users\pc50\Desktop\CopyFolder1\Y2_value\
The second one is \\192.168.2.52\NetworkCopyFolder\Y2_value\ This one is on a network drive. Not sure if the path I gave you is enough.

Please note that your macro needs to check if Y2_value folder exists in the two copy folders, and create it them they don't. Do you think this one can do the job?

VBA Code:
      '/// new check for range added
      strPath = cstrMyBase & .Range("Y2").Value
      If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
      End If

Thank you once again!
 
Upvote 0
Good to hear you managed to do it.
If you would like to post the solution then it is perfectly fine to mark your post as the solution to help future readers. It could be posting the working final code. Otherwise, please do not mark a post that doesn't contain a solution.
 
Upvote 0
Good to hear you managed to do it.
If you would like to post the solution then it is perfectly fine to mark your post as the solution to help future readers. It could be posting the working final code. Otherwise, please do not mark a post that doesn't contain a solution.
Sure, I'll post it tomorrow!
 
Upvote 0
Good to hear you managed to do it.
If you would like to post the solution then it is perfectly fine to mark your post as the solution to help future readers. It could be posting the working final code. Otherwise, please do not mark a post that doesn't contain a solution.
VBA Code:
Sub CopyFile()
    On Error GoTo ErrHandler
    Dim SourcePath As String
    Dim DestPath As String
    Dim FileName As String
    
    'Set the base folder path
    SourcePath = "C:\Users\pc50\Desktop\New results\"
    
    'Get the subfolder names from cells F7 and Y2
    Dim SubFolder1 As String
    Dim SubFolder2 As String
    SubFolder1 = Range("F7").Value
    SubFolder2 = Range("Y2").Value
    
    'Combine the base path and subfolder names
    SourcePath = SourcePath & SubFolder1 & "\" & SubFolder2 & "\"
    
    'Set the base destination folder path
    DestPath = "C:\Users\pc50\Desktop\Testfolder\"
    
    'Get the subfolder name from cell Y2
    SubFolder2 = Range("Y2").Value
    
    'Combine the base path and subfolder name
    DestPath = DestPath & SubFolder2 & "\"
    
    'Get the filename from a cell and add the file extension
    FileName = Range("AH1").Value & ".pdf"
    
    'Create the destination folder directory if it doesn't exist
    If Dir(DestPath, vbDirectory) = "" Then
        MkDir DestPath
    End If
    
    'Copy the file
    FileCopy SourcePath & FileName, DestPath & FileName
    
Exit Sub
ErrHandler:
    MsgBox "An error occurred while copying the file. Please check if the file exists and try again."
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,224,823
Messages
6,181,180
Members
453,021
Latest member
Justyna P

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