Modify existing copy-files VBA program

dracoholikus

New Member
Joined
Feb 28, 2021
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
Hello, recently i found a macro from this post,


And it really helped me as i have a time consuming copy-paste files process in CAD designing, but i require a modification to the program so i can acess the full potential of the tool and lack the knowledge to do it.

So the situation is,
ACTUAL PROGRAM(extracted and minimally modified)
  1. The user inputs the folder for the files to be pasted;
  2. The user select which cells contains the filenames that will be searched on a main directory(inserted on the program);
  3. The program initiate it's search for the file extensions ".pdf" and ".dxf", when it finds, copy and paste into the selected folder;
  4. Program ends;

NEW PROGRAM
  1. The user inputs the main folder for the files to be pasted;
  2. The user select which cells contains the filenames that will be searched on a main directory(inserted on the program);
  3. The user select which cells contains the materials that will be used to create each specific subfolder on the main folder;
    1. It will compare the material name on the excel list with a set of string variables, like,
      1. CHAPA AÇO 1020 1,20MM = 1,2mm(string use to name the folder);
  4. The user select which cell contains the model of the machine - yellow area in the image, "LFH 40";
  5. The user select which cell contains the code of the machine - yellow area in the image, "61962";
  6. The user select which cell contains the revision of the machine - yellow area in the image, "rev 03";
  7. The program creates subfolders using the material, model, code and revision, like the image below,
folder name = Model + Material + Internal system code + Revision
1614565652778.png

  1. The program initiate it's search for the file extensions ".pdf" and ".dxf", when it finds, it will copy and paste the files into the subfolder that relates to the material of the part, in the image below, the file "0005.0001.0117" will be pasted in the "LFH 40 1,2mm (61962) (rev 03)" subfolder;
  2. Program ends;

I intend to use this to make some "quick-send" laser cutting material based on a excel list that i export from the SOLIDWORKS Bill of Materials. The SolidWorks export has its own program(that i created using it's API) that export the excel list exactly like the image below, all formatted,

1614565541223.png

Red = the codes the program will search;
Blue = the materials that it will use to create specific folders;
Yellow = from left to right, equipament model, my internal system code and revision of design;


VBA Code:
VBA Code:
Option Explicit

Public Sub CopyFiles_Partial_File_Names()

Dim sourcePath As String, destinationPath As String
Dim filesRange As Range

sourcePath = "C:\Users\Avell\Google Drive LTCH\SOLIDWORKS"  'main folder and its subfolders to search for the partial file names
destinationPath = Application.InputBox("Input destination folder to all files:", , , , , , , 2) 'folder where matching file names will be copied to

On Error Resume Next
Set filesRange = Application.InputBox("Please select the cells containing partial file names to be copied:", "Copy Files", ActiveWindow.RangeSelection.Address, , , , , 8)
On Error GoTo 0
If filesRange Is Nothing Then Exit Sub

Copy_Matching_PDF_Files filesRange, sourcePath, destinationPath
   
End Sub
   
   
Private Sub Copy_Matching_PDF_Files(filesRange As Range, sourceFolder As String, ByVal destinationFolder As String)

Static FSO As Object
Dim FSfile As Object
Dim FSfolder As Object
Dim fileCell As Range
Dim model As String
Dim revision As String
Dim code As String
Dim ac120 As String
Dim ac200 As String
Dim ac318 As String
Dim ai120 As String
Dim folderac120 As String
Dim folderac200 As String
Dim folderac318 As String
Dim folderai120 As String
Dim fileMaterial As Range
   
Set model = Worksheets(ActiveSheet.Name).Cells(1, "A").Value
Set revision = Worksheets(ActiveSheet.Name).Cells(1, "C").Value
Set code = Worksheets(ActiveSheet.Name).Cells(1, "B").Value
Set ac120 = "CHAPA AÇO 1020 1,20MM"
Set ac200 = "CHAPA AÇO 1020 2,00MM"
Set ac318 = "CHAPA AÇO 1020 3,18MM"
Set ai120 = "CHAPA INOX 304 1,2MM ESCOVADO COM PELICULA"
Set folderac120 = "1,20mm"
Set folderac200 = "2,00mm"
Set folderac318 = "3,18mm"
Set folderai120 = "INOX 304 1,20mm"
Set fileMaterial = filesRange.Offset(, 2)

If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")

If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"

Set FSfolder = FSO.GetFolder(sourceFolder)
   
For Each fileCell In filesRange
For Each FSfile In FSfolder.Files
If LCase(FSfile.Name) Like LCase("*" & fileCell.Value & "*.pdf") Then
Debug.Print "COPY " & FSfile.Path & " TO " & destinationFolder
FSfile.Copy destinationFolder, OverwriteFiles:=True
End If
Next
Next
   
For Each fileCell In filesRange
For Each FSfile In FSfolder.Files
If LCase(FSfile.Name) Like LCase("*" & fileCell.Value & "*.dxf") Then
Debug.Print "COPY " & FSfile.Path & " TO " & destinationFolder
FSfile.Copy destinationFolder, OverwriteFiles:=True
End If
Next
Next
       
For Each FSfolder In FSfolder.SubFolders
Copy_Matching_PDF_Files filesRange, FSfolder.Path, destinationFolder
Next

End Sub



Can anyone enlight me on how to procede with the modification? I want to learn how to start modifying, with some guidance if possible...
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

Watch MrExcel Video

Forum statistics

Threads
1,130,407
Messages
5,641,968
Members
417,249
Latest member
serrulate

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
Top