VBA Better way to do this

[dee101]

I have a folder I am copying pictures out of, if there are more than one picture of the same thing it will have a .1, .2 .3 ….after it.

This is working but I know that is a better way to do it I just don’t know how, there may be as many as 30 pictures of the same subject and doing this for that many is a lot.

Is is being used in Excel 2003

Thanks

For Each myCell In myRng.Cells

FileCopy Source:=myOldPath & myCell.Value & ".jpg", _

Destination:=myNewPath & myCell.Value & ".jpg"

FileCopy Source:=myOldPath & myCell & ".1.jpg", _

Destination:=myNewPath & myCell & ".1.jpg"

FileCopy Source:=myOldPath & myCell & ".2.jpg", _

Destination:=myNewPath & myCell & ".2.jpg"

FileCopy Source:=myOldPath & myCell & ".3.jpg", _

Destination:=myNewPath & myCell & ".3.jpg"

FileCopy Source:=myOldPath & myCell & ".4.jpg", _

Destination:=myNewPath & myCell & ".4.jpg"

FileCopy Source:=myOldPath & myCell & ".5.jpg", _

Destination:=myNewPath & myCell & ".5.jpg"


‘More numbers would be here

Next myCell

 

[PeteWright]

Try this:

Sub copy()
   Dim myCell
   Dim myRng As Range
   Set myRng = Range("TYPE_DESIRED_RANGE_HERE") 'eg. Range("A1:A99")
   Dim myOldPath As String
   myOldPath = "TYPE_PATH_TO_OLD_FILES_HERE" 'eg. "C:\myfiles\oldfiles\"
   Dim myNewPath As String
   myNewPath = "TYPE_PATH_TO_NEW_FILES_HERE" 'eg. "C:\myfiles\newfiles\"
   Dim fso As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   Dim c As Integer
   c = 0
   Dim ext As String
   ext = ".jpg"
  
   For Each myCell In myRng.Cells
      Do While fExist(myOldPath, myCell.Value2, c, ext)
         Call fCopy(myOldPath, myNewPath, myCell.Value2, c, ext)
         c = c + 1
      Loop
      c = 0
   Next myCell
End Sub

Function fExist(fpath As String, fname As String, c As Integer, ext As String) As Boolean
   Dim fso As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   If c = 0 Then
      fExist = fso.FileExists(fpath & fname & ext)
   Else
      fExist = fso.FileExists(fpath & fname & "." & c & ext)
   End If
End Function

Sub fCopy(fpath_old As String, fpath_new As String, fname As String, c As Integer, ext As String)
   Dim fso As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   If c = 0 Then
      fso.CopyFile fpath_old & fname & ext, fpath_new & fname & ext
   Else
      fso.CopyFile fpath_old & fname & "." & c & ext, fpath_new & fname & "." & c & ext
   End If
End Sub

In order to work you need to enable "Microsoft Scripting Runtime" under Tools > References

Please let me know if it works for you or if you need further assistance.

Tested with sample data as follows:
Excel sheet with
cell A1 = asdf
cell A2 = qwerty
Files in "old" directory
asdf.jpg
asdf.1.jpg
qwerty.jpg
qwerty.1.jpg
qwerty.2.jpg
qwerty.3.jpg
VBA variables
myRng = Range("A1:A2")
myOldPath = "C:\Temp\Excel\images\old\"
myNewPath = "C:\Temp\Excel\images\new\"

 

[Bosquedeguate]

try this

  Dim filenum As String
  Dim fileext As String
  
  i = 0
  filenum = ""
  fileext = ".jpg"
  For Each myCell In myRng.Cells
    Debug.Print myCell & filenum & fileext

    FileCopy Source:=myOldPath & myCell.Value & filenum & fileext, _

    Destination:=myNewPath & myCell.Value & ".jpg"
    
    i = i + 1
    filenum = "." & i

'More numbers would be here

  Next myCell

 

[dee101]

PeteWright, I got it working with your code. Thanks

 

[dee101]

Bosquedeguate, when I tried your code I only got the first picture

The picture names I tested it on were

3050
3225
3226

Picture 3050 had 6 pictures
Picture 3225 had 1 picture
Picture 3226 had 2 pictures


This is what was in the Immediate window

Pic #.jpg
3050.1.jpg
3225.2.jpg
3226.3.jpg

 

[Bosquedeguate]

try this

  Dim filenum As String
  Dim fileext As String
 
  i = 0
  filenum = ""
  fileext = ".jpg"
  For Each myCell In myRng.Cells
    Debug.Print myCell & filenum & fileext

    FileCopy Source:=myOldPath & myCell.Value & filenum & fileext, _

    Destination:=myNewPath & myCell.Value & ".jpg"
   
    i = i + 1
    filenum = "." & i

'More numbers would be here

  Next myCell

change the Destination: = line to ...

FileCopy Source:=myOldPath & myCell.Value & filenum & fileext, _

Destination:=myNewPath & myCell.Value & filenum & fileext

 

[dee101]

Bosquedeguate, only getting picture 3050.1 copied with the change?

Same thing in the Immediate window