Macro required to copy list of files to new folder.

[Colcreate]

I need a macro to copy a variable amount of between 19 and 600 jpg files from an existing folder to a new folder. The selected image file names will be listed in a worksheet range (A1:A500) and the new folder name will be stated in cell B1. I am already using a macro to generate html pages which are automatically saved in the "B1" folder. The required images need to be saved in the same folder or possibly in a sub folder.
Any ideas?

 

[ravishankar]

Hi
paste the following codes into the macro window ( Alt F11, Insert > module). B1 will have destination file path and source file path to be changed in the code from C:\current folder\ to your source file path.

Sub kopy()
Dim a As Integer, x As Integer
Dim b As String
x = Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To x
b = Cells(a, 1)
FileCopy "C:\current folder\" & b, Cells(1, 2) & b
Next a
MsgBox "All files were copied"
End Sub

run the macro. It will copy files listed in col A to the folder mentioned in B1
ravi

 

[Colcreate]

Ravishankar,
Thank you that worked perfectly. Could it be modified to check to see if the "copy to" folder exists and if not to make the folder? Also could the path to the "copy to" folder be written into the macro (C:\Documents and Settings\User\Desktop\) just leaving the final folder name to be added from the worksheet?
Thank you again.
Col

 

[ravishankar]

Hi
Replace the code with
FileCopy "C:\current folder\" & b, "C:\Documents and Settings\User\Desktop\" & Cells(1, 2) & b
Now B1 can have just folder name.
perhaps other fellow members can help you with code for creation/checking for presence of folder.
Ravi

 

[giursgen]

hi everyone, the macro works great, but i need to search also in the subdirectory...
i'm a newby .. i've no idea how to do it..could you please help me and include the search i the subdirectory???
thank you

 

[sudhashire]

'-----------------------------------SELECTING SOURCE FOLDER--------------------------------------------
Sub SelectFolder1()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With

If sFolder <> "" Then ' if a file was chosen
Range("B4").Value = sFolder
End If
End Sub

'-----------------------------------SELECTING DESTINATION FOLDER--------------------------------------------
Sub SelectFolder2()
Dim sFolder2 As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder2 = .SelectedItems(1)
End If
End With

If sFolder2 <> "" Then ' if a file was chosen
Range("B8").Value = sFolder2
End If
End Sub

'-----------------------------------COPY FILES--------------------------------------------
Sub CopyFilesX()
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
Dim c As Range, rPatterns As Range
Dim bBad As Boolean

sSrcFolder = ActiveSheet.Range("B4").Value
sTgtFolder = ActiveSheet.Range("B8").Value

Dim lastRow As Long
lastRow = Range("A1").End(xlDown).Row

Set rPatterns = ActiveSheet.Range("A2:A" & lastRow).SpecialCells(xlConstants)
For Each c In rPatterns
sFilename = Dir(sSrcFolder & "\" & "*" & c.Text & "*")
If sFilename = "" Then
c.Interior.ColorIndex = 3
bBad = True
Else
While sFilename <> ""
FileCopy sSrcFolder & "\" & sFilename, sTgtFolder & "\" & sFilename
sFilename = Dir()
c.Interior.ColorIndex = 4
Wend
End If
Next c
If bBad Then MsgBox "Some files were not found. " & _
"These were highlighted for your reference."
End Sub

 

[newb2vba]

'-----------------------------------SELECTING SOURCE FOLDER--------------------------------------------
Sub SelectFolder1()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With

If sFolder <> "" Then ' if a file was chosen
Range("B4").Value = sFolder
End If
End Sub

'-----------------------------------SELECTING DESTINATION FOLDER--------------------------------------------
Sub SelectFolder2()
Dim sFolder2 As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder2 = .SelectedItems(1)
End If
End With

If sFolder2 <> "" Then ' if a file was chosen
Range("B8").Value = sFolder2
End If
End Sub

'-----------------------------------COPY FILES--------------------------------------------
Sub CopyFilesX()
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
Dim c As Range, rPatterns As Range
Dim bBad As Boolean

sSrcFolder = ActiveSheet.Range("B4").Value
sTgtFolder = ActiveSheet.Range("B8").Value

Dim lastRow As Long
lastRow = Range("A1").End(xlDown).Row

Set rPatterns = ActiveSheet.Range("A2:A" & lastRow).SpecialCells(xlConstants)
For Each c In rPatterns
sFilename = Dir(sSrcFolder & "\" & "*" & c.Text & "*")
If sFilename = "" Then
c.Interior.ColorIndex = 3
bBad = True
Else
While sFilename <> ""
FileCopy sSrcFolder & "\" & sFilename, sTgtFolder & "\" & sFilename
sFilename = Dir()
c.Interior.ColorIndex = 4
Wend
End If
Next c
If bBad Then MsgBox "Some files were not found. " & _
"These were highlighted for your reference."
End Sub

how can this code be edited to copy a single file. the code works perfectly in a range but when the range includes only one cell it brings back an error code 52.