Create Folder, Copy & Move File - VBA @pp_92

PHOTO EMBED

Sun Feb 20 2022 02:10:22 GMT+0000 (Coordinated Universal Time)

Saved by @pharehphatah #vba 

Private Sub Create_Folder()
'CREATE FOLDER'

Dim ToPath As String

ToPath = ThisWorkbook.Worksheets("1").Range("A1").Value
MkDir ToPath

End Sub


Sub Copy_One_File()
    FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls"
End Sub

Sub Move_Rename_One_File()
'You can change the path and file name'
    Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls"
End Sub

Sub Delete_One_File()
'You can change the path and file name'
    Kill "C:\Users\Ron\SourceFolder\Test.xls"
End Sub
 
'Copy or move more files or complete folders'
'Note: Read the commented code lines in the code'

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath'
'Note: If ToPath already exist it will overwrite existing files in this folder'
'if ToPath not exist it will be made for you'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    'If you want to create a backup of your folder every time you run this macro'
    'you can create a unique folder with a Date/Time stamp.'
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss").'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Sub Move_Rename_Folder()
'This example move the folder from FromPath to ToPath'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'
    'Note: It is not possible to use a folder that exist in ToPath'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If

    FSO.MoveFolder Source:=FromPath, Destination:=ToPath
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath

End Sub


Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath'
'You can also use this to copy the files from the last ? days'
'If Fdate >= Date - 30 Then'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

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

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

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub


Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    FileExt = "*.xl*"  '<< Change
    'You can use *.* for all files or *.doc for Word files'

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

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

Sub Move_Certain_Files_To_New_Folder()
'This example move all Excel files from FromPath to ToPath'
'Note: It will create the folder ToPath for you with a date-time stamp'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") _
           & " Excel Files" & "\"    '<< Change only the destination folder'

    FileExt = "*.xl*"   '<< Change'
    'You can use *.* for all files or *.doc for word files'

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

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        MsgBox "No files in " & FromPath
        Exit Sub
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    FSO.CreateFolder (ToPath)

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

'VBA Deleting All Files and Subfolders'
Sub VBAF1_Delete_All_Files_and_Subfolders()
    
    'Variable declaration'
    Dim sFolderPath As String
    Dim FSO As Object
    
     'Define Folder Path'
    sFolderPath = "C:\VBAF1\Test\"
    
    'Check if slash is added'
    If Right(sFolderPath, 1) = "\" Then
        'If added remove it from the specified path'
        sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
    End If
            
    'Create FSO Object'
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Check Specified Folder exists or not'
    If FSO.FolderExists(sFolderPath) Then
    
          'Delete All Files'
          FSO.DeleteFile sFolderPath & "\*.*", True
                        
          'Delete All Subfolders'
		  'Change the code'
          FSO.DeleteFolder sFolderPath & "\*.*", True

			
		 'Remark Sample:'
		 'Sample Delete File in Folder Download "C:\Users\Downloads\"'
		 'FSO.DeleteFolder sFolderPath & "\*.*", True'

		 'Sample Delete Folder in Folder Download "C:\Users\Downloads\FOLDER1\"'
		 'FSO.DeleteFolder sFolderPath , True'
          
     End If
    
End Sub
content_copyCOPY

All Create Folder

https://www.rondebruin.nl/win/s3/win026.htm