valie
11-15-2011, 05:16 AM
Hi there, I am hoping that someone can help me.
I have to read through a certain directory, that contains say 5000 files, and have to split it up into smaller directories of 200 files each to archive them.
So far, I have been able to create a new directory and copy 200 files into it, but when, in my mind, I create the next directory, the code copies the same files into the second directory.
How do I keep my currency and carry on from where I have left off in the previous new directory?
This is my code so far:
Option Compare Text
Option Explicit
Global FSO As Object
Global ShellApp As Object
Global file As Object
Global SubFolder As Object
Global Directory As String
Global srcDirectory As String
Global Problem As Boolean
Global ExcelVer As Integer
Global PATH_START As String
Global f As Long
Global newpath As String
Global oldpath As String
Global n As Long
Sub HyperlinkFileList()
Dim Preface As String
Dim i As Long
'Turn off screen flashing
Application.ScreenUpdating = True
Set FSO = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Kies een bron directory", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.Path & "\"
srcDirectory = ShellApp.self.Path
Set SubFolder = FSO.getfolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("U hebt een ongeldige directory gekozen!" & vbCrLf & _
"Wil U nogmaals proberen?", vbYesNoCancel, _
"Directory Benodigd") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
PATH_START = srcDirectory
'// Created a reference to FileSystemObject; see vba help. //
Set FSO = CreateObject("Scripting.FileSystemObject")
Preface = "deel"
i = 1
f = 0
Do
If Not FSO.FolderExists(PATH_START & "\" & Preface & i) Then
FSO.CreateFolder (PATH_START & "\" & Preface & i)
Directory = (PATH_START & "\" & Preface & i)
End If
Directory = (PATH_START & "\" & Preface & i)
f = f + 1
n = 0
MoveFiles
i = i + 1
Loop Until i > 10000 Or f < 200
End Sub
Sub MoveFiles()
On Error GoTo FileCopyError
Set FSO = CreateObject("Scripting.FileSystemObject")
newpath = Directory & "\"
oldpath = srcDirectory & "\"
Do
MovePartFiles
Loop Until n > 200
Exit Sub
FileCopyError:
MsgBox "Er is een probleem opgetreden met het copiëren de bestanden"
End
End Sub
Sub MovePartFiles()
For Each file In FSO.getfolder(PATH_START).Files
If n <= 20 Then
'Copy to shared folder
FSO.CopyFile oldpath & file.Name, newpath & file.Name
n = n + 1
f = f + 1
Else
n = 201
Exit Sub
End If
Next file
End Sub
I have to read through a certain directory, that contains say 5000 files, and have to split it up into smaller directories of 200 files each to archive them.
So far, I have been able to create a new directory and copy 200 files into it, but when, in my mind, I create the next directory, the code copies the same files into the second directory.
How do I keep my currency and carry on from where I have left off in the previous new directory?
This is my code so far:
Option Compare Text
Option Explicit
Global FSO As Object
Global ShellApp As Object
Global file As Object
Global SubFolder As Object
Global Directory As String
Global srcDirectory As String
Global Problem As Boolean
Global ExcelVer As Integer
Global PATH_START As String
Global f As Long
Global newpath As String
Global oldpath As String
Global n As Long
Sub HyperlinkFileList()
Dim Preface As String
Dim i As Long
'Turn off screen flashing
Application.ScreenUpdating = True
Set FSO = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Kies een bron directory", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.Path & "\"
srcDirectory = ShellApp.self.Path
Set SubFolder = FSO.getfolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("U hebt een ongeldige directory gekozen!" & vbCrLf & _
"Wil U nogmaals proberen?", vbYesNoCancel, _
"Directory Benodigd") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
PATH_START = srcDirectory
'// Created a reference to FileSystemObject; see vba help. //
Set FSO = CreateObject("Scripting.FileSystemObject")
Preface = "deel"
i = 1
f = 0
Do
If Not FSO.FolderExists(PATH_START & "\" & Preface & i) Then
FSO.CreateFolder (PATH_START & "\" & Preface & i)
Directory = (PATH_START & "\" & Preface & i)
End If
Directory = (PATH_START & "\" & Preface & i)
f = f + 1
n = 0
MoveFiles
i = i + 1
Loop Until i > 10000 Or f < 200
End Sub
Sub MoveFiles()
On Error GoTo FileCopyError
Set FSO = CreateObject("Scripting.FileSystemObject")
newpath = Directory & "\"
oldpath = srcDirectory & "\"
Do
MovePartFiles
Loop Until n > 200
Exit Sub
FileCopyError:
MsgBox "Er is een probleem opgetreden met het copiëren de bestanden"
End
End Sub
Sub MovePartFiles()
For Each file In FSO.getfolder(PATH_START).Files
If n <= 20 Then
'Copy to shared folder
FSO.CopyFile oldpath & file.Name, newpath & file.Name
n = n + 1
f = f + 1
Else
n = 201
Exit Sub
End If
Next file
End Sub