folder to folder copy using vba with conditions

[smd_1976]

hi,

using vba i need to copy files from one folder to another folder. if filename in destination folder exists it shud check the date modified in source folder against destination folder, if it matches overwrite file, if file name is same but date modified is different then save the file with new file name i.e. filename & datemodified

thanks if advance...

[CBrine]

How do you get the filename you want to copy? Do you want to select a specfic file? Or and entire folder of files? Do you want prompts or is this something that you want to have hardcoded and run in the background using preset variables?

Cal

[smd_1976]

apologies for not being more descriptive.
i've built a routine in excel to list all the file names,size,created,modified,accessed,full path in seperate columns
here is the code for file listing
----------------------------

Sub GetFileList()

Dim strFolder As String
Dim varFileList As Variant
Dim fso As Object, myFile As Object
Dim myResults As Variant
Dim l As Long

' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub 'user cancelled
strFolder = .SelectedItems(1)
End With

' Get a list of all the files in this directory.
' Note that this isn't recursive... although it could be...
varFileList = fcnGetFileList(strFolder)

If Not IsArray(varFileList) Then
MsgBox "No files found.", vbInformation
Exit Sub
End If

' Now let's get all the details for these files
' and place them into an array so it's quick to dump to XL.
ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)

' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(0, 1) = "Size"
myResults(0, 2) = "Created"
myResults(0, 3) = "Modified"
myResults(0, 4) = "Accessed"
myResults(0, 5) = "Full path"

Set fso = CreateObject("Scripting.FileSystemObject")

' Loop through our files
For l = 0 To UBound(varFileList)
Set myFile = fso.GetFile(CStr(varFileList(l)))
myResults(l + 1, 0) = CStr(varFileList(l))
myResults(l + 1, 1) = myFile.Size
myResults(l + 1, 2) = myFile.DateCreated
myResults(l + 1, 3) = myFile.DateLastModified
myResults(l + 1, 4) = myFile.DateLastAccessed
myResults(l + 1, 5) = myFile.Path
Next l

' Dump these to a worksheet
fcnDumpToWorksheet myResults

'tidy up
Set myFile = Nothing
Set fso = Nothing


End Sub

Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
' Returns a one dimensional array with filenames
' Otherwise returns False

Dim f As String
Dim i As Integer
Dim FileList() As String

If strFilter = "" Then strFilter = "*.*"

Select Case Right$(strPath, 1)
Case "\", "/"
strPath = Left$(strPath, Len(strPath) - 1)
End Select

ReDim Preserve FileList(0)

f = Dir$(strPath & "\" & strFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop

If FileList(0) <> Empty Then
fcnGetFileList = FileList
Else
fcnGetFileList = False
End If
End Function
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)

Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long

If mySh Is Nothing Then

'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
'Set wb = Application.Workbooks.Add
Set wb = ActiveWorkbook
Application.SheetsInNewWorkbook = iSheetsInNew
'Application.ActiveWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)

Else

Set mySh = sh

End If

With sh

Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
.UsedRange.Columns.AutoFit

End With

Set sh = Nothing
Set wb = Nothing

End Sub

-------------------------------
once the files are listed. it should run through all the files in excel alongwith date modified, check if the file exists and matches with the date modified in destination folder(this folder contains files). if file name and modification dates are same ignore, if file name same and modification dates are different, copy the file with from source folder alongwith date modification (filename &datemodified) into the destination folder
hope its more clear this time

Edited 23-Dec-09 by geekgirlau. Reason: insert vba tags

[GTO]

Greetings,

Please definitely test well, using a couple of temp folders and some created/junk files. As I'm at home and using 2000, I am unable to complete testing, as folderpicker is not available.

Using your current code as base:


Option Explicit

Sub CompareFiles()
Dim _
wksTmp As Worksheet, _
wksOld As Worksheet, _
rngFileNames As Range, _
rngFName As Range, _
rngFoundFile As Range, _
bolCancelled As Boolean, _
strPathNew As String, _
strPathOld As String, _
dblOld As Double, _
dblNew As Double, _
FSO As Object '<---FileSystemObject

'// Based on current code. //
Set wksOld = ActiveSheet
'// Call current sub w/added args. Note that we will send a same-named flag, //
'// 'bolCancelled', and the Boolean will be returned. We will use this to see if we//
'// should continue. //
Call GetFileList(bolCancelled, , "Select Source/Old Folder:")
'// Bail if user cancelled folderpicker. //
If bolCancelled Then Exit Sub

'// Add a temp sheet to hold info/data re 'newer' files. //
Set wksTmp = Worksheets.Add(Before:=Worksheets(1))

'// Again call procedure, this time to produce info/data re 'newer folder/files'. //
Call GetFileList(bolCancelled, wksTmp, "Select Destination Folder:")

'// Again, bail if user cancels, and del created sheet if so. //
If bolCancelled Then
Application.DisplayAlerts = False
wksTmp.Delete
Application.DisplayAlerts = True
Exit Sub
End If

'// Nothing was cancelled, we're on our way... //
With wksTmp
'// Return path to 'new' folder. //
strPathNew = Left(.Range("F2"), InStrRev(.Range("F2"), "\"))
'// Return path to 'old' folder. //
strPathOld = Left(wksOld.Range("F2"), InStrRev(wksOld.Range("F2"), "\"))

'// Set a reference to the range holding 'source/old' files. //
Set rngFileNames = wksOld.Range("A2:A" & wksOld.Cells(Rows.Count, 1).End(xlUp).Row)

Set FSO = CreateObject("Scripting.FileSystemObject")

'// For each 'source/old' filename... //
For Each rngFName In rngFileNames

'// Ensure we don't retain an object (file) from last loop... //
Set rngFoundFile = Nothing
'// Try and set a reference to the found file in the 'destination/new' folder.//
Set rngFoundFile = .Range("A:A").Find(What:=rngFName.Value)

'// If we don't find a same-named file, rngFoundFile will ret Nothing. //
If Not rngFoundFile Is Nothing Then
'// If we found a same-named file, get a value reference Modified date //
'// from bpth files. //
dblOld = CLng(DateValue(rngFName.Offset(, 3).Value)) _
+ CDbl(TimeValue(rngFName.Offset(, 3).Value))
dblNew = CLng(DateValue(rngFoundFile.Offset(, 3).Value)) _
+ CDbl(TimeValue(rngFoundFile.Offset(, 3).Value))

'// If the Mod date and time is not the same... //
If Not dblOld = dblNew Then
'// Copy the file from the 'old/source' folder, to the 'new/destination//
'// folder, renaming the file along the way. //
FSO.CopyFile Source:=strPathOld & rngFName, _
Destination:=strPathNew & _
Left(rngFName, InStrRev(rngFName, ".") - 1) & _
Chr(32) & _
Format(dblOld, "MM-DD-YY hhmm") & ".xls", _
OverWriteFiles:=False
End If
End If
Next

'// Kill the tmp sheet //
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub
Sub GetFileList(Optional CancelOperation As Boolean, _
Optional Sh As Worksheet, _
Optional DialogTitle As String)
Dim strFolder As String
Dim varFileList As Variant
Dim FSO As Object, myFile As Object
Dim myResults As Variant
Dim l As Long
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
'// ***ADDED*** //
If Not DialogTitle = vbNullString Then .Title = DialogTitle
.Show
If .SelectedItems.Count = 0 Then Exit Sub 'user cancelled
strFolder = .SelectedItems(1)
End With
' Get a list of all the files in this directory.
' Note that this isn't recursive... although it could be...
varFileList = fcnGetFileList(strFolder)
If Not IsArray(varFileList) Then
MsgBox "No files found.", vbInformation
'// ***ADDED*** //
CancelOperation = True
Exit Sub
End If
' Now let's get all the details for these files
' and place them into an array so it's quick to dump to XL.
ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(0, 1) = "Size"
myResults(0, 2) = "Created"
myResults(0, 3) = "Modified"
myResults(0, 4) = "Accessed"
myResults(0, 5) = "Full path"
Set FSO = CreateObject("Scripting.FileSystemObject")
' Loop through our files
For l = 0 To UBound(varFileList)
Set myFile = FSO.GetFile(CStr(varFileList(l)))
myResults(l + 1, 0) = CStr(varFileList(l))
myResults(l + 1, 1) = myFile.Size
myResults(l + 1, 2) = myFile.DateCreated
myResults(l + 1, 3) = myFile.DateLastModified
myResults(l + 1, 4) = myFile.DateLastAccessed
myResults(l + 1, 5) = myFile.Path
Next l
' Dump these to a worksheet
'// ***CHANGED/ADDED*** //
If Sh Is Nothing Then
fcnDumpToWorksheet myResults
Else
fcnDumpToWorksheet myResults, Sh
End If
'tidy up
Set myFile = Nothing
Set FSO = Nothing

End Sub
Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
' Returns a one dimensional array with filenames
' Otherwise returns False
Dim f As String
Dim i As Integer
Dim FileList() As String
If strFilter = "" Then strFilter = "*.*"
Select Case Right$(strPath, 1)
Case "\", "/"
strPath = Left$(strPath, Len(strPath) - 1)
End Select
ReDim Preserve FileList(0)
f = Dir$(strPath & "\" & strFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop
If FileList(0) <> Empty Then
fcnGetFileList = FileList
Else
fcnGetFileList = False
End If
End Function
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim Sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'// ***I was not making sense of this part*** //
''make a workbook if we didn't get a worksheet
'iSheetsInNew = Application.SheetsInNewWorkbook
'Application.SheetsInNewWorkbook = 1
''Set wb = Application.Workbooks.Add
Set wb = ActiveWorkbook
'Application.SheetsInNewWorkbook = iSheetsInNew
'Application.ActiveWorkbook = iSheetsInNew
Set Sh = wb.Sheets(1)
Else
'// *** I believe this part was backwards.*** //
'Set mySh = Sh
Set Sh = mySh

End If
With Sh
Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
.UsedRange.Columns.AutoFit
End With
Set Sh = Nothing
Set wb = Nothing
End Sub


Hope that helps,

Mark