Option Explicit
Sub Move_Files_New()
Dim oFSO As Object 'FileSystemObject to perform file copies
Dim oREX As Object 'RegularExpressions to match strings with wildcards
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oREX = CreateObject("VBScript.RegExp")
Dim r As Long, lstR As Long 'row counters
Dim i As Long, j As Long 'iteration counters
Dim d As Integer, f As Integer 'variables to find counter in string
Dim IsDate As Boolean 'store YES/NO column as boolean
Dim sSN As String, sLN As String 'file name [Source, Last import]
Dim sSE As String, sLE As String 'file extension [Source, Last import]
Dim sSP As String, sDP As String 'file path (full) [Source, Destination]
Dim sSC As String, sLC As String 'file counter [Source, Last import]
Dim sSD As String, sLD As String 'file counter date [Source, Last import]
Dim v As Variant, sFmt As String 'for manipulating date counter
Dim dSD As Date, dLD As Date 'file counter as date value [Source, Last import]
Dim lX As Long 'file counter difference
Dim t1 As String, t2 As String, t3 As String 'for building file strings
Const cSrcLoc As Long = 2 'Column number: VRN Source Location
Const cImpLoc As Long = 3 'Column number: VRN Import Location
Const cLst_FN As Long = 7 'Column number: Last Import File Name
Const cSrc_FN As Long = 8 'Column number: Latest File (Source)
Const cCtrDig As Long = 10 'Column number: Counter Digits Wide
Const cCtrOff As Long = 11 'Column number: Counter Offset (from end)
Const cCtrDat As Long = 12 'Column number: Counter Is Date?
Const cPfixTS As Boolean = True 'prefix a timestamp to imported files?
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Insurer List")
'show the worksheet and reset the cursor
ws.Activate
ws.[A1].Select
'find last row
lstR = ws.Cells(Rows.Count, cSrcLoc).End(xlUp).Row
'iterate through the rows
For r = 2 To lstR
'set file names
sSN = ws.Cells(r, cSrc_FN).Value
sLN = ws.Cells(r, cLst_FN).Value
'set extensions
If InStrRev(sSN, ".") Then sSE = Mid(sSN, InStrRev(sSN, ".")) Else sSE = ""
If InStrRev(sLN, ".") Then sLE = Mid(sLN, InStrRev(sLN, ".")) Else sLE = ""
'remove ext from file names
sSN = Mid(sSN, 1, Len(sSN) - Len(sSE))
sLN = Mid(sLN, 1, Len(sLN) - Len(sLE))
'varibles for counter
d = Val(ws.Cells(r, cCtrDig)) 'digits wide
f = Val(ws.Cells(r, cCtrOff)) 'offset (to left)
'grab counters from file name
sSC = Mid(sSN, Len(sSN) - (d - 1) - f, d)
sLC = Mid(sLN, Len(sLN) - (d - 1) - f, d)
'compare counters
IsDate = IsTrue(ws.Cells(r, cCtrDat))
If IsDate Then
'we need to determine what format the date is in
' only works for dates with month as the middle section
' i.e. will not work for US dates with day in the middle
oREX.Global = True 'all matches
oREX.Pattern = "[^a-zA-Z0-9]" 'non-alphanumeric
If oREX.Test(sSC) Then 'a good, delimited date
'check the first delimiter position to determine order
Set v = oREX.Execute(sSC)
If InStr(1, sSC, CStr(v(0))) = 3 Then
sFmt = JoinStr(CStr(v(0)), "DD", "MM", "YYYY")
Else
sFmt = JoinStr(CStr(v(0)), "YYYY", "MM", "DD")
End If
'replace source delimiter with VBA-recognised delimiter
' and then set the date
dSD = DateValue(oREX.Replace(sSC, "/"))
dLD = DateValue(oREX.Replace(sLC, "/"))
ElseIf Val(Mid(sSC, 3, 2)) > 12 Then 'very simple test that doesn't work for years 2000 - 2012
sFmt = "YYYYMMDD"
dSD = DateValue(JoinStr("/", Mid(sSC, 1, 4), Mid(sSC, 5, 2), Mid(sSC, 7, 2)))
dLD = DateValue(JoinStr("/", Mid(sLC, 1, 4), Mid(sLC, 5, 2), Mid(sLC, 7, 2)))
Else
sFmt = "DDMMYYYY"
dSD = DateValue(JoinStr("/", Mid(sSC, 1, 2), Mid(sSC, 3, 2), Mid(sSC, 5, 4)))
dLD = DateValue(JoinStr("/", Mid(sLC, 1, 2), Mid(sLC, 3, 2), Mid(sLC, 5, 4)))
End If
lX = dSD - dLD
Else
lX = Val(sSC) - Val(sLC)
End If
'get source file name without counter
t1 = Left(sSN, InStr(1, sSN, sSC) - 1)
t2 = Mid(sSN, InStr(1, sSN, sSC) + Len(sSC))
Debug.Print "Row"; r, t1 & "{#}" & t2
If lX > 0 Then
'import all the files
For j = 1 To lX
'create new filename with counter
If IsDate Then
t3 = t1 & Format(dLD + j, sFmt) & t2
Else
t3 = t1 & Format(Val(sLC) + j, String(Len(sLC), "0")) & t2
End If
'set paths
sSP = ws.Cells(r, cSrcLoc).Value & t3 & sSE
sDP = ws.Cells(r, cImpLoc).Value & IIf(cPfixTS, TimeStamp, "") & t3 & sSE
'check source and destination files
If oFSO.FileExists(sSP) And Not oFSO.FileExists(sDP) Then
Debug.Print , "Src:= " & sSP
Debug.Print , "Dst:= " & sDP
'perform copy
oFSO.CopyFile Source:=sSP, Destination:=sDP
'add to xfer counter
i = i + 1
Debug.Print , , "** Transfer Successful **"
End If
Next j
ElseIf lX < 0 Then
MsgBox "Something went wrong. Counter difference is " & lX & " for row " & r, vbCritical
Debug.Print , "Error: Counter difference is " & lX
End If
Next r
MsgBox i & " file(s) imported successfully."
Set oFSO = Nothing
Set oREX = Nothing
End Sub
Function IsTrue(TargetCells As Range) As Boolean
Dim b() As Variant
Dim r As Range
Dim c As Long
If TargetCells.Count <= 0 Then Exit Function
ReDim b(1 To TargetCells.Count)
For Each r In TargetCells
c = c + 1
b(c) = _
r.Value <> 0 And _
r.Value <> False And _
r.Value <> "FALSE" And _
r.Value <> "NO" And _
r.Value <> ""
Next r
IsTrue = True
For c = LBound(b) To UBound(b)
If Not b(c) Then IsTrue = False: Exit For
Next c
End Function
Function JoinStr(Delimiter As String, ParamArray Strings()) As String
Dim itm As Variant
For Each itm In Strings
JoinStr = JoinStr & Delimiter & itm
Next itm
JoinStr = Mid(JoinStr, 2)
End Function
Function TimeStamp() As String
TimeStamp = Format(Now, "YYYYMMDD_hhmmss") & "_IMPORTED_"
End Function
'*** Testing Code Below ***
'*** For Creating Test Files ***
Sub TestDirs()
On Error Resume Next
Dim i As Integer
MkDir "C:\TEST\"
MkDir "C:\TEST\SRC"
MkDir "C:\TEST\DST"
For i = 1 To 13
MkDir "C:\TEST\SRC\Insurer " & i
MkDir "C:\TEST\DST\Insurer " & i
Next i
End Sub
Sub InsertDirs()
Dim r As Long
For r = 2 To 14
With ActiveSheet
.Cells(r, 2).Value = "C:\TEST\SRC\Insurer " & r - 1 & "\"
.Cells(r, 3).Value = "C:\TEST\DST\Insurer " & r - 1 & "\"
End With
Next r
End Sub
Sub CreateFiles()
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim r As Long
'All extensions changed to .txt for testing
For r = 2 To 14
With ActiveSheet
oFSO.CreateTextFile .Cells(r, 2).Value & .Cells(r, 8).Value
oFSO.CreateTextFile .Cells(r, 3).Value & .Cells(r, 6).Value
End With
Next r
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks