macro for moving folders

[errtu]

I have two folders A & B.

I need a macro that will create a new folder C and move all contents from A & B to C.

edit. i forgot, every time it should create a different folder. so that everyday i'll get folder C, D, E, F (maybe name the folders based on date)

 

[VoG]

Take a look at the VBA methods MkDir and Name.

 

[AlphaFrog]

Define the Folders (in red) for Folder A and Folder B
The macro assumes all the files in both folders have unique names.

Sub Move_Files()
    
    Dim Folders, Folder, FolderC$
    Dim Ext$, MoveFile$, i&
    
    Folders = Array([COLOR="Red"]"C:\Temp1\", "C:\Temp2\"[/COLOR])
    FolderC = "C:\" & Format(Date, "mmm dd yyyy") & "\"
    
    If Len(Dir(FolderC, vbDirectory)) = 0 Then MkDir FolderC
    Ext = "*.xls*"
    
    For Each Folder In Folders
        MoveFile = Dir(Folder & Ext)
        Do While Len(MoveFile)
            Name Folder & MoveFile As FolderC & MoveFile
            i = i + 1
            MoveFile = Dir()
        Loop
    Next Folder
    
    If i Then
        MsgBox i & " files moved to " & FolderC, vbInformation, "Files Moved"
    Else
        MsgBox "No files were moved."
    End If
    
End Sub

 

[errtu]

Define the Folders (in red) for Folder A and Folder B
The macro assumes all the files in both folders have unique names.

Sub Move_Files()
    
    Dim Folders, Folder, FolderC$
    Dim Ext$, MoveFile$, i&
    
    Folders = Array([COLOR=Red]"C:\Temp1\", "C:\Temp2\"[/COLOR])
    FolderC = "C:\" & Format(Date, "mmm dd yyyy") & "\"
    
    If Len(Dir(FolderC, vbDirectory)) = 0 Then MkDir FolderC
    Ext = "*.xls*"
    
    For Each Folder In Folders
        MoveFile = Dir(Folder & Ext)
        Do While Len(MoveFile)
            Name Folder & MoveFile As FolderC & MoveFile
            i = i + 1
            MoveFile = Dir()
        Loop
    Next Folder
    
    If i Then
        MsgBox i & " files moved to " & FolderC, vbInformation, "Files Moved"
    Else
        MsgBox "No files were moved."
    End If
    
End Sub

I get user-defined type not defined

 

[AlphaFrog]

Is there a line that is highlighted when you get the error?

Try using this instead as the two Dim lines...

    Dim Folders As Variant, Folder As Variant, FolderC As String
    Dim Ext As String, MoveFile As String, i As Long

Did you change the text in red to something else? If yes, what?

 

[errtu]

ok my bad i added a Dim objFSO As FileSystemObject line and forgot to reference windows script host object model.

I get path not found though, and get

Private Sub DONE_Click()
 Dim Folders, Folder, FolderC$
    Dim Ext$, MoveFile$, i&
    
    Folders = Array("C:\Users\Khaos\Documents\My Dropbox\corte electronico\", "C:\Users\Khaos\Documents\My Dropbox\Laur\")
    FolderC = "C:\Users\Khaos\Documents\My Dropbox\Public\LOGS DIARIOS\" & Format(Date, "mmm dd yyyy") & "\"
    
    If Len(Dir(FolderC, vbDirectory)) = 0 Then MkDir FolderC
    Ext = "*.xls*"
    
    For Each Folder In Folders
        MoveFile = Dir(Folder & Ext)

mkdir gets highlighted

 

[AlphaFrog]

The code I posted doesn't use FileSystemObject

MkDir FolderC will make just the last folder (the dated folder) in in the string FolderC
My guess is that the full path C:\Users\Khaos\Documents\My Dropbox\Public\LOGS DIARIOS\ or specifically the folder LOGS DIARIOS\ doesn't exist yet.

 

[pawest]

I think I'm running into the same issue, as I use scripting, too. I'm having some issues with my code. Any alternatives to get this to work would be greatly appreciated. Here is the code:

Sub Copy_Rename_File1()
Dim FromPath As String, ToPath As String, CheckPath As String
Dim Lastrow As Long, i As Long

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

If MsgBox("Are you sure you want to move all stale files?", vbYesNo) <> vbYes Then
Exit Sub
End If

If Len(Dir((ActiveSheet.Cells(i, 3).Value & "\Stale Files"), vbDirectory)) = 0 Then
MkDir (ActiveSheet.Cells(i, 3).Value & "\Stale Files")
On Error GoTo 0

End If

i = 1 + i
0 For i = 1 To Lastrow
FromPath = ActiveSheet.Cells(i, 4).Value
ToPath = ActiveSheet.Cells(i, 3).Value & "\Stale Files\" & ActiveSheet.Cells(i, 2).Value

FileCopy Source:=FromPath, Destination:=ToPath

Next i

End Sub

 

[AlphaFrog]

This part of your code...

If Len(Dir((ActiveSheet.Cells(i, 3).Value & "\Stale Files"), vbDirectory)) = 0 Then
MkDir (ActiveSheet.Cells(i, 3).Value & "\Stale Files")
On Error GoTo 0
End If

...is before the For-Next i loop. So Checking\Making each directory "\Stale Files" path was not within the loop.


Try something like this (not tested)...

Sub Copy_Rename_File1()
    
    Dim FromPath As String, ToPath As String, i As Long
    
    If MsgBox("Are you sure you want to move all stale files?", vbYesNo) <> vbYes Then Exit Sub
    
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        
        If Len(Dir((Cells(i, "C").Value & "\Stale Files"), vbDirectory)) = 0 Then
            MkDir Cells(i, "C").Value & "\Stale Files"
        End If
        
        FromPath = Cells(i, "D").Value
        ToPath = Cells(i, "C").Value & "\Stale Files\" & Cells(i, "B").Value
        FileCopy Source:=FromPath, Destination:=ToPath
        
    Next i
    
End Sub

 

[pawest]

Alpha Frog,

This seems to be working. I will continue to test it but thanks so much for the quick response and great advice!

I'm an intern for a financial institution and if "alpha" in your name means you're investment-related, best of luck grabbing alpha from your trading.

I appreciate your help!

-Peter