macro to move files in the list

[luvbite38]

Hi

I am using the following code to copy and move the files which are listed in the column B of worksheet called sheet2.

It is taking considerably long time to do the operation.

Is there another quickest way of moving the files or someone can kindly optimise the following code to make it work faster.

Sub Setup4()
Application.ScreenUpdating = False
Dim myDir As String
Dim myDest As String
Dim myCell As String
Dim myCount As Single
'mycount is the starting row that the file names start at
myCount = 1
Do
'Change this to the Column you want to read
myCell = Range("B" & myCount)
'Change this to the location that the files are in
myDir = ThisWorkbook.Path
'Change this to the location the files are to be copied to
myDest = ThisWorkbook.Path & "\" & "Moment & Shear Outputs"
FileCopy myDir & "\" & myCell, myDest & "\" & myCell
myCount = myCount + 1
'Will loop until the first empty cell
Loop Until IsEmpty(Range("B" & myCount))
Application.ScreenUpdating = True
End Sub

Kind Regards,

 

[bertie]

For optimization:


If you use a range variable you can do away with recalculating myCount.
If you use a variable for the path you will only calculate ThisWorkbook.Path once.

For example

  [color=green]'start cell[/color]
  [color=darkblue]Set[/color] rng = [COLOR="Red"]Sheets("Sheet2").Range("B1")[/COLOR]
  myPath = ThisWorkbook.Path & "\"

We then loop through the column B until we find an empty cell.

  [color=green]'loop through column B until you find an empty cell[/color]
  [color=darkblue]Do[/color] [color=darkblue]Until[/color] rng = ""

Set up the source and destination file:

    myDir = myPath & rng.Value
    myDest = myPath & "Moment & Shear Outputs\" & rng.Value

If you want to move the file use the Name function:

    [color=green]'========================[/color]
    [color=green]'move and rename the file[/color]
    [color=green]'========================[/color]
    Name myDir [color=darkblue]As[/color] myDest

Copying the file leaving the original in the source folder will be the main time consuming part of the procedure:

    [color=green]'=======================[/color]
    [color=green]'copy and move the files[/color]
    [color=green]'=======================[/color]
    FileCopy myDir, myDest

Then we get the next file:

    [color=green]'next file[/color]
    [color=darkblue]Set[/color] rng = rng.Offset(1, 0)

The full code is:
NB the Name function is commented out

[color=darkblue]Sub[/color] SetUp4a()
  [color=darkblue]Dim[/color] rng [color=darkblue]As[/color] Range
  [color=darkblue]Dim[/color] myDir [color=darkblue]As[/color] [color=darkblue]String[/color]
  [color=darkblue]Dim[/color] myDest [color=darkblue]As[/color] [color=darkblue]String[/color]
  [color=darkblue]Dim[/color] myPath [color=darkblue]As[/color] [color=darkblue]String[/color]
  
  [color=green]'start cell[/color]
  [color=darkblue]Set[/color] rng = Sheets("Sheet2").Range("B1")
  myPath = ThisWorkbook.Path & "\"
  
  [color=green]'loop through column B until you find an empty cell[/color]
  [color=darkblue]Do[/color] [color=darkblue]Until[/color] rng = ""
    myDir = myPath & rng.Value
    myDest = myPath & "Moment & Shear Outputs\" & rng.Value

    [color=green]'========================[/color]
    [color=green]'move and rename the file[/color]
    [color=green]'========================[/color]
    [color=green]'Name myDir As myDest[/color]
    
    [color=green]'=======================[/color]
    [color=green]'copy and move the files[/color]
    [color=green]'=======================[/color]
    FileCopy myDir, myDest
    
    [color=green]'next file[/color]
    [color=darkblue]Set[/color] rng = rng.Offset(1, 0)
  [color=darkblue]Loop[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

Hope this helps,
Bertie

 

[bertie]

PS

You can even do away with the myDir and myDest variables and put their contents directly into the FileCopy line.

I have used variables to make the code easier to read.
Bertie

 

[luvbite38]

Mate,

you're a champ...... thanks a million, zillion.......

 

[Legacy 333383]

Hi, i know this post is really old, just hope someone reads this and can help me.
i am doing a very simular thing when i am wanting a macro to fime a list of pdf files listed in column b in a folder on my desktop to a new folder on my desktop. I cant seem to make the one above work for me.

 

[bertie]

Hi Brian, welcome to the forum

It is an old post. Please note I haven't tested the advice I post below, but the logic is sound.
Here is what the code does.

Set up paths to the folders you are working with. For example, say you want to move files in the "Temp" folder to the "Temp" folder archive; you would use:

  oldPath = "C:\Temp\"
  newPath = "C:\Temp\Archive\"

NB REMEMBER END BACKSLASH

Then you set up the range you are going to loop through. In this example Sheet2 starting at cell B1. EDIT IF NECESSARY

  Set rng = Sheets("Sheet2").Range("B1")

Then you loop through the list until you reach an empty cell.

 Do Until rng = ""

Build up the old and new FULL FILE PATHS

      'build up the full path to the old file
      oldFile = oldPath & rng.Value & ".pdf"
      
      'build up the full path to the new file you want to create
      newFile = newPath & rng.Value & ".pdf"

NB If you don't need to add the ".pdf" file extension delete as highlighted (red)
rng.value is the value in the cell on the spreadsheet.


And copy the file to the new folder:

      'copy the old file to the new new folder
      FileCopy oldFile, newFile

If we put all that together we get:

Sub SetUp4a()
  Dim rng As Range
  Dim oldPath As String
  Dim newPath As String
  Dim oldFile As String
  Dim newFile As String
  
  '================================================
  'Set the paths to the folders you are processing
  'REMEMBER END BACKSLASH
  '================================================
  oldPath = "C:\Temp\"
  newPath = "C:\Temp\Archive\"
  
  '=======================================================
  'set up the start of the range you want to loop through
  'EDIT SHEET NAME AND FIRST CELL ADDRESS IF NECESSARY
  '======================================================
  Set rng = Sheets("Sheet2").Range("B1")
  
   '==================================================
  'loop through column B until you find an empty cell
  '==================================================
  Do Until rng = ""
      
      'build up the full path to the old file
      oldFile = oldPath & rng.Value & ".pdf"
      
      'build up the full path to the new file you want to create
      newFile = newPath & rng.Value & ".pdf"
  
      'copy the old file to the new new folder
      FileCopy oldFile, newFile
    
    'get the next file by moving down one row
    Set rng = rng.Offset(1, 0)
  Loop
End Sub

Hope this helps you understand the process,
Bertie