Copy worksheet to various folders

[ipbr21054]

Hi,
I have file called INFO
I also have Folders of which all have the file INFO within.
Folders are named like so JUNE JULY AUGUST ETC ETC

As opposed to copy / paste manually to every folder can this be done using some kind of code etc
Basically i need to put the same file into each folder in one step as opposed to many times of doing the same thing.
I understand that the existing file in the folder will be replaced & that is fine,

 

[rollis13]

This could be a solution for you:

Option Explicit
Sub Copy_File_To_Folders()
    Dim FileName As String
    Dim FromPath As String
    Dim ToPath As String
    Dim fldrArr As Variant
    Dim x      As Long
    Dim FSO    As Object
    FileName = "INFO.TXT"                         '<- change name as needed
    FromPath = "F:\Prove\Test\"                   '<- change path as needed
    ToPath = "F:\Prove\Test1\Archivio\"           '<- change path as needed
    fldrArr = Array("JUNE", "JULY", "AUGUST", "ETC") '<- change and add folders as needed (folders need to be existing)
    For x = LBound(fldrArr) To UBound(fldrArr)
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.CopyFile Source:=FromPath & FileName, Destination:=ToPath & fldrArr(x) & "\"
    Next x
    MsgBox "Done!"
    Set FSO = Nothing
End Sub

 

[ipbr21054]

Hi,
How do i apply it ?
Do i put on a command button in the INFO file ?

 

[rollis13]

It's better to have a master file to contain the macro. From there you can manually (if prefered you can create a button) launch the macro but if the file INFO is an Excel file you can use it as container.

 

[ipbr21054]

Hi

That worked great.

At the end of the month i remove that months folder.
So today is May 1st so i remove 04 APRIL

When i run the code i see a Run Time Error.
This is because 04 APRIL isnt now there.
I understand why the RTE is shown.

Assuming ALL folders are present but there is an error then i need to see some kind of message to inform me.

BUT

I also need to remove last months folder BUT allow the code to continue to run with the error because i removed it.
Can the code look at the pc current date in this case 1st May so it knows that 04 APIRL isnt required etc ??

Obviously this would apply in the future so if pc date is 12th August then the code isnt expecting to see 04 APRIL 05 MAY 06 JUNE 07 JULY

Make sense ?

Many thanks

 

[rollis13]

Well, since I have no idea on how your project is structured, I can't say that what you said doesn't make sense.
If it were only for errors on missing folders you can add a line of code to skip it, like this:

fldrArr = Array("JUNE", "JULY", "AUGUST", "ETC") '<- change and add folders as needed
On Error Resume Next                          '<- added
For x = LBound(fldrArr) To UBound(fldrArr)

 

[ipbr21054]

Please check edit & post correct code as now i get compile error.

Thanks

Private Sub NewFileToFolders_Click()
    Dim FileName As String
    Dim FromPath As String
    Dim ToPath As String
    Dim myArr As Variant
    Dim x As Long
    Dim FSO As Object
    FileName = "TESTFILE.xlsm"
    FromPath = "C:\Users\Ian\Desktop\EBAY\ACCOUNTS\"
    ToPath = "C:\Users\Ian\Desktop\EBAY\ACCOUNTS\CURRENT SHEETS\"
    myArr = Array("04 APRIL", "05 MAY", "06 JUNE", "07 JULY", "08 AUGUST", "09 SEPTEMBER", "10 OCTOBER", "11 NOVEMBER", "12 DECEMBER", "13 JANUARY", "14 FEBRUARY", "15 MARCH", "16 APRIL")
    For x = LBound(myArr) To UBound(myArr)
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.CopyFile Source:=FromPath & FileName, Destination:=ToPath & myArr(x) & "\"
    Next x
    fldrArr = Array("04 APRIL", "05 MAY", "06 JUNE", "07 JULY", "08 AUGUST", "09 SEPTEMBER", "10 OCTOBER", "11 NOVEMBER", "12 DECEMBER", "13 JANUARY", "14 FEBRUARY", "15 MARCH", "16 APRIL")
    On Error Resume Next
    For x = LBound(fldrArr) To UBound(fldrArr)
    MsgBox "ALL FILES NOW TRANSFERED TO FOLDERS", vbInformation, "CONFIRMATION MESSAGE"

    Set FSO = Nothing
End Sub

 

[rollis13]

In my post #6 there was only one line "<- added" .

By the way, I would use this statement: MsgBox "FILE NOW TRANSFERED TO ALL AVAILABLE FOLDERS", vbInformation, "CONFIRMATION MESSAGE"

 

[ipbr21054]

Sorry I read it wrong.

I will just add On Error Resume Next

 

[ipbr21054]

Morning,
I have now added that On Error Resume Next & works well thanks.

Last request & hope you can assist, the current code in use is shown below.

The file that the code is saved to is called TESTFILE
When i run the code i would like the saved file to be renamed & saved as SUMMARY

So FileName = "TESTFILE.xlsm" BUT Saved FileName = "SUMMARY.xlsm"

Option Explicit
Private Sub NewFileToFolders_Click()
    Dim FileName As String
    Dim FromPath As String
    Dim ToPath As String
    Dim fldrArr As Variant
    Dim x      As Long
    Dim FSO    As Object
    FileName = "TESTFILE.xlsm"
    FromPath = "C:\Users\Ian\Desktop\EBAY\ACCOUNTS\"
    ToPath = "C:\Users\Ian\Desktop\EBAY\ACCOUNTS\CURRENT SHEETS\"
    fldrArr = Array("04 APRIL", "05 MAY", "06 JUNE", "07 JULY", "08 AUGUST", "09 SEPTEMBER", "10 OCTOBER", "11 NOVEMBER", "12 DECEMBER", "13 JANUARY", "14 FEBRUARY", "15 MARCH", "16 APRIL")
    On Error Resume Next
    For x = LBound(fldrArr) To UBound(fldrArr)
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.CopyFile Source:=FromPath & FileName, Destination:=ToPath & fldrArr(x) & "\"
    Next x
    MsgBox "ALL FILES NOW TRANSFERED TO FOLDERS", vbInformation, "CONFIRMATION MESSAGE"
    Set FSO = Nothing
End Sub