Excel/VBA - Move all types of files

Excel/VBA - Move all types of files

Small application to move your files (whatever the type) from a "Source" to "Destination" directory.

Introduction

Software required for this application: Excel (all versions> 97)

References - VBE editor: "Microsoft Scripting Runtime"

This procedure uses a library of objects which by default is not included in the VBE editor. We must therefore add a reference to this library:

Open VBE: (to access it from a worksheet of your Excel workbook, press ALT + F11 simultaneously)

Menu: Tools

Choice: References

Select "Microsoft Scripting Runtime"

Two UserForm will be needed:

In VBE:

Menu: Insert

Choice: UserForm

The controls include:

In UserForm1:

- 4 command buttons, (CommandButton1, CommandButton2, CommandButton3, CommandButton4)

- 2 Labels, to host the paths (Label1, Label2)

- 5 Labels, to host the names of the column headers of the Listbox (Label3, Label4, Label5, Label6, Label7)

- 2 CheckBox (CheckBox1 (select all files), CheckBox2 (New directory))

- A ListBox (ListBox1)

In UserForm2:

- 2 command keys (CommandButton1, CommandButton2)

- 1 TextBox (TextBox1)

- Label 1 (optional)

The UserForm1

Option Explicit

'---------------------------------------

'Procédure de sélection de tous les fichiers dans la listbox

Private Sub CheckBox1_Click()

Dim i As Long

If CheckBox1.Value = True Then

For i = 0 To ListBox1.ListCount - 1

If ListBox1.Selected(i) = False Then ListBox1.Selected(i) = True

Next i

Else

For i = 0 To ListBox1.ListCount - 1

If ListBox1.Selected(i) = True Then ListBox1.Selected(i) = False

Next i

End If

End Sub

'-------------------------------------

'Montre l'UserForm2 afin de créer un nouveau répertoire

Private Sub CheckBox2_Click()

If CheckBox2.Value = True Then

UserForm2.Show

End If

End Sub

'--------------------------------------

'Choix du répertoire destination

Private Sub CommandButton2_Click()

Dim objShell As Object, objFolder As Object

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then

MsgBox "Abandon opérateur", vbCritical, "Annulation"

Else

Label2.Caption = objFolder.ParentFolder.ParseName(objFolder.Title).Path

End If

End Sub

'---------------------------------------

'Déplacement des fichiers sélectionnés

Private Sub CommandButton3_Click()

Dim i As Long

Dim source As String, destin As String, message As String

Dim oFSO As Scripting.FileSystemObject

Dim Rep As Integer

message = "Etes-vous sur(e) de vouloir déplacer le(s) fichier(s) sélectionné(s) de : " & vbLf & vbLf & Label1.Caption & vbLf & vbLf & "vers : " & vbLf & vbLf & Label2.Caption

Rep = MsgBox(message, vbYesNo + vbQuestion, "Confirmation")

If Rep = vbYes Then

Set oFSO = New Scripting.FileSystemObject

For i = 0 To ListBox1.ListCount - 1

If ListBox1.Selected(i) = True Then

source = Label1.Caption & "" & ListBox1.List(i)

destin = Label2.Caption & "" & ListBox1.List(i)

If oFSO.FileExists(source) Then

oFSO.MoveFile source, destin

End If

End If

Next i

ElementsRepertoire Label1.Caption

MsgBox "Déplacement(s) effectué(s).", vbOKOnly + vbInformation, "Fin de traitement"

Else

MsgBox "Abandon opérateur", vbCritical, "Annulation"

End If

End Sub

'--------------------------------------------

'Effacement des contrôles de l'UserForm1

Private Sub CommandButton4_Click()

ListBox1.Clear

Label1.Caption = ""

Label2.Caption = ""

CheckBox1.Value = False

CheckBox2.Value = False

End Sub

'------------------------------------------

'Initialisation de la listbox

Private Sub UserForm_Initialize()

With ListBox1

.ColumnCount = 5

.ColumnWidths = "170;50;60;50;200"

.SetFocus 'inutile, uniquement esthétique

End With

End Sub

'----------------------------------------

'Choix du répertoire source

Private Sub CommandButton1_Click()

Dim objShell As Object, objFolder As Object

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then

MsgBox "Abandon opérateur", vbCritical, "Annulation"

End

Else

ElementsRepertoire objFolder.ParentFolder.ParseName(objFolder.Title).Path

End If

End Sub

'-----------------------------------------

'remplissage de la listbox

Private Sub ElementsRepertoire(Chemin As String)

Dim objShell As Object, strFileName As Object

Dim objFolder As Object

Dim NomFic As String, Passe As String

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.Namespace(CStr(Chemin))

Label1 = Chemin

ListBox1.Clear

For Each strFileName In objFolder.Items

If strFileName.isFolder = False Then

Passe = Chemin & "" & strFileName & "*.*"

NomFic = Dir(Passe)

With ListBox1

.AddItem NomFic

.List(ListBox1.ListCount - 1, 1) = objFolder.GetDetailsOf(strFileName, 1)

.List(ListBox1.ListCount - 1, 2) = Format(objFolder.GetDetailsOf(strFileName, 4), "DD/MM/YYYY")

.List(ListBox1.ListCount - 1, 3) = Format(objFolder.GetDetailsOf(strFileName, 3), "DD/MM/YYYY")

.List(ListBox1.ListCount - 1, 4) = objFolder.GetDetailsOf(strFileName, 14)

End With

End If

Next strFileName

End Sub

UserForm2

Option Explicit

Dim CheminRepParent As String

'-------------------------------------------

'choix du répertoire parent, dans lequel sera créé notre répertoire

Private Sub CommandButton1_Click()

Dim objShell As Object, objFolder As Object

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then

MsgBox "Abandon opérateur", vbCritical, "Annulation"

Else

CheminRepParent = objFolder.ParentFolder.ParseName(objFolder.Title).Path

End If

End Sub

'--------------------------------------------

'Création du répertoire

Private Sub CommandButton2_Click()

Dim oFSO As Scripting.FileSystemObject

Dim oFld As Folder

Dim CheminComplet As String

If TextBox1 = "" Then Exit Sub

Set oFSO = New Scripting.FileSystemObject

CheminComplet = CheminRepParent & "" & TextBox1

If oFSO.FolderExists(CheminComplet) Then

MsgBox "Ce dossier existe déjà"

Exit Sub

Else

On Error Resume Next

Set oFld = oFSO.CreateFolder(CheminComplet)

End If

UserForm1.Label2.Caption = CheminComplet

UserForm1.CheckBox2.Value = False

Unload Me

End Sub

'----------------------------------------------------

'Empêcher la saisie de caractères interdits ou déconseillés

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

If InStr("""!{['^]}/*?<>|:", Chr(KeyAscii)) <> 0 Then

MsgBox "Caractère interdit ou déconseillé"

KeyAscii = 0

End If

End Sub

'-----------------------------------------------

'vidage du Textbox1

Private Sub UserForm_Initialize()

TextBox1 = ""

End Sub

Example of use

On an Excel spreadsheet, draw a command button ( View menu, toolbar: Toolkit controls).

In the module of the sheet (to access it: Right-click the sheet tab > View Code) copy and paste this code:

Private Sub CommandButton1_Click()

'Démarrer

UserForm1.Show

End Sub

Download the sample workbook

You can download the sample workbook: here