Solved: Split a Directory into Smaller Directories and Copy the Files Across

[valie]

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:
[VBA]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[/VBA]

[GTO]

Quickly read, but I do not see any limitations as to file types. So... presuming we want to move all the files in one folder, to created folders - wherein the created folders get 200 files each and we keep doing this until we're out of files...

What would the desired folder naming convention be? Something like 'Archive_001', 'Archive_002'...'Archive_200' ?

[valie]

Hi GTO,

Thank you very much for responding.

Yes, you've got it on the button. From one huge directory to a number of predefined little ones. The naming is exactly as you have it, Archive001, Archive002 ... Archive200.

[mdmackillop]

You could use SetAttr and GetAttr to set/read an attribute which would flag copied files.
If you are using Office 2003 or earlier, you could use FileSearch and use the file index.

[GTO]

Valie,

Did you solve this?

Mark

[valie]

Valie,

Did you solve this?

Mark

GTO,

Yes, I’ve solved it by listing the file names in an Excel spreadsheet first and then by reading them off, I copy the files from the source directory to the smaller target directory. That works properly now.

I can post the code if you would like to see it.

Btw, how do I post my code on the forum,? Last time I copied it into my post and somewhere someone, I think that it was one of the administrators, had put it into the nice green block.

Regards,
Gert

[mdmackillop]

Btw, how do I post my code on the forum,?

Select your code and click the green VBA button.

[valie]

This is how I solved it, eventually. It does run a very long time!

[VBA]
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 rowIndex As Long
Global newpath As String
Global oldpath As String
Global interfaceFile As String
Global EOF As Boolean
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")
interfaceFile = Application.ActiveWorkbook.Path + "\List Directory.xls"

'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Kies een bron directory", 0, "x:\\")

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
ListFiles
'// Created a reference to FileSystemObject; see vba help. //
Set FSO = CreateObject("Scripting.FileSystemObject")

Preface = "deel"

i = 1
rowIndex = 1
EOF = False

'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 EOF
'MoveFiles

End Sub
Sub ListFiles()
Dim oFolder As Object
Dim oFile As Object
Dim kk25 As Integer

Set oFolder = FSO.Getfolder(PATH_START)

'Lists all the files in the current directory

kk25 = 1

For Each oFile In oFolder.Files
Worksheets("Blad1").Cells(kk25, 1).Value = oFile.Name

kk25 = kk25 + 1
Next

End Sub
Sub MoveFiles()
Dim ws As Worksheet
Dim fileNaam As String
Dim wb As Workbook

Set wb = ActiveWorkbook
'Set wb = Application.ActiveWorkbook.Name
'wb.Activate
Set ws = wb.Worksheets(1) 'hardcoded!

On Error GoTo FileCopyError

Set FSO = CreateObject("Scripting.FileSystemObject")
newpath = Directory & "\"
oldpath = srcDirectory & "\"

'rowIndex = 5
f = 1
Do
'Copy to shared folder
fileNaam = ws.Cells(rowIndex, 1)
If fileNaam = "" Then
EOF = True
Else
FSO.CopyFile oldpath & fileNaam, newpath & fileNaam
rowIndex = rowIndex + 1
f = f + 1
End If

Loop Until EOF Or f > 200

Exit Sub

FileCopyError:
MsgBox "Er is een probleem opgetreden met het copiëren de bestanden"
End

End Sub

[/VBA]