santh
12-10-2019, 06:28 AM
I have an excel VBA code that:
1. uses cell information (in sheet 2) to create a directory folder structure
2. uses cell information to place the correct file to the correct foolder (that was previously created)
3. renames the files when 255 characters are exceeded
4. when there are both native files (i.e. excel, word, autocad) and pdf files of the same file these are place in sheet 3 (named attachments)
5. Creates a hyperlink in the forth tab when the files have been moved succesfully
6. the excel
I need your help for the following because i have no clue where to start from
The above is an everyday task and i need a new excel to be generated everytime new documents are received and placed to the right place, with the exact format of the Sheet2 and sheet 3 (attachments) that will have all the past and present files with the addition of a hyperlink to the last column
Public CopyingFilesNo As IntegerPublic Function IsFolderExists(txt As String) As Boolean
'returns true if the folder exists already, false if it does not.
IsFolderExists = CreateObject("Scripting.FileSystemObject").FolderExists(txt)
End Function
Sub file_move()
On Error GoTo ErrorHandler:
Dim myFile As String
Dim myPath As String 'folder to test
Dim myPaths 'to check each folder in the destination path
Dim i As Long, j As Integer, CountF As Integer
Dim ws As Worksheet 'sheet with data
Dim wsSV As Worksheet 'sheet to update
Dim lr As Long 'last row with data
Dim baseFolder As String
Dim SourceFolder As String
Dim Folder1 As String
Dim TempFolder As String
Dim Folder2 As String
Dim Folder2Plus As String
Dim tempFolderTwo As String
Dim subFolderTwo As String
Dim Folder3 As String
Dim Folder3Plus As String
Dim tempFolderThree As String
Dim subFolderThree As String
Dim Folder4 As String
Dim Folder4Plus As String
Dim tempFolderFour As String
Dim subFolderFour As String
Dim FileName As String
Dim FIleNameNew As String
Dim FileNameFinal As String
Dim CheckString As String
Dim Cnt As Integer
Dim rng As Range
baseFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE\"
SourceFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE"
Set ws = Worksheets("Sheet2") 'change sheet name as needed
Set wsSV = Worksheets("DocumentList")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
Cnt = 1
CopyingFilesNo = 0
For i = 2 To lr
'Update*******************************************
Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
Set rng = wsSV.Range("A" & Cnt + 1)
'*************************************************
myPath = Replace(ws.Range("C" & i).Value, "/", "-")
myPaths = Split(myPath, "\")
myPath = vbNullString
Folder1 = Trim(ws.Range("A" & i).Value)
Dim fso As New FileSystemObject
If fso.FolderExists(baseFolder + Folder1) = False Then
fso.CreateFolder baseFolder + "" + Folder1
End If
'*********************************
Folder2 = Replace(ws.Range("c" & i).Value, "/", "")
Folder2Plus = Replace(ws.Range("d" & i).Value, "/", "")
tempFolderTwo = Trim(Folder2) + " " + Trim(Folder2Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo)
End If
'************************************************************************
Folder3 = Replace(ws.Range("e" & i).Value, "/", "")
Folder3Plus = Replace(ws.Range("f" & i).Value, "/", "")
tempFolderThree = Trim(Folder3) + " " + Trim(Folder3Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree)
End If
'************************************************************************
Folder4 = Replace(ws.Range("g" & i).Value, "/", "")
Folder4Plus = Replace(ws.Range("h" & i).Value, "/", "")
tempFolderFour = Trim(Folder4) + " " + Trim(Folder4Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour)
End If
'************************************************************************
FileName = Replace(ws.Range("AE" & i).Value, "/", "")
CheckString = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FileName
If Len(CheckString) > 255 Then
Dim diff As Integer
diff = Len(CheckString) - 255
If fso.FileExists(SourceFolder + "\" + FileName) = True Then
FIleNameNew = Mid(FileName, 1, Len(FileName) - 5 - diff) + Mid(FileName, Len(FileName) - 4, 5)
fso.MoveFile SourceFolder + "\" + FileName, SourceFolder + "\" + FIleNameNew
FileNameFinal = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FIleNameNew
Call CopyFiles(SourceFolder, FIleNameNew, FileNameFinal)
wsSV.Range("A" & Cnt + 1) = FileNameFinal
wsSV.Range("B" & Cnt + 1) = FileName
wsSV.Range("C" & Cnt + 1) = ws.Range("v" & i).Value
wsSV.Range("D" & Cnt + 1) = ws.Range("t" & i).Value
wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), FileNameFinal
End If
Else
FileNameFinal = CheckString
'Call fso.CopyFile(SourceFolder + "\" + FileName, FileNameFinal, True)
If CopyFiles(SourceFolder, FileName, FileNameFinal) = True Then
ws.Range("AZ" & i).Value = True
Call WriteToDocumentList(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", FileName, ws.Range("v" & i).Value, ws.Range("t" & i).Value)
End If
End If
'**********************************
If (ws.Range("af" & i).Value) <> 0 Then
CountF = 1
For CountF = 1 To ws.Range("af" & i).Value
Call AddAttachments(ws.Range("t" & i).Value, CountF, baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", SourceFolder)
Next CountF
End If
Next i
MsgBox "FILES COPIED:" & CopyingFilesNo & " Files", vbInformation
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileName & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorInput"
End Sub
Private Function AddAttachments(FileIndex As String, Current As Integer, FileDestination As String, SourceFolder As String) As Boolean
On Error GoTo ErrorHandler:
Dim wsAtcm As Worksheet
Dim lRow As Long
Dim rangeAtcm As Range
Dim FoundCell As Range
Dim FileNametcm As String
Dim wsSV As Range
' Set wsSV = Worksheets("DocumentList")
Set wsAtcm = Worksheets("Attachments")
Set rangeAtcm = wsAtcm.Range("A1")
Set FoundCell = wsAtcm.Range("B:B").Find(what:=FileIndex, lookat:=xlWhole)
FileNametcm = rangeAtcm.Range("I" & FoundCell.Row).Value
rangeAtcm.Range("B" & FoundCell.Row).Value = rangeAtcm.Range("B" & FoundCell.Row).Value & " Copied"
Call CopyFiles(SourceFolder, FileNametcm, FileDestination & FileNametcm)
Call WriteToDocumentList(FileDestination, FileNametcm, rangeAtcm.Range("D" & FoundCell.Row).Value, FileIndex)
AddAttachments = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileNametcm & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorAttachm"
End Function
Private Function CopyFiles(SourcePath As String, FileName As String, DestinationPath As String) As Boolean
Dim fso As New FileSystemObject
Dim NewStringSource As String
Dim NewDestinationPath As String
On Error GoTo ErrorHandler:
NewStringSource = SourcePath + "\" + FileName
NewDestinationPath = DestinationPath
If InStr(SourcePath + "\" + FileName, "®") Then
NewStringSource = Replace(SourcePath + "\" + FileName, "®", "")
fso.MoveFile SourcePath + "\" + FileName, NewStringSource
NewDestinationPath = Replace(DestinationPath, "®", "")
End If
Call fso.CopyFile(NewStringSource, NewDestinationPath, True)
fso.DeleteFile (NewStringSource)
CopyingFilesNo = CopyingFilesNo + 1
CopyFiles = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileName & vbCrLf & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorcOPYING"
End Function
Private Sub WriteToDocumentList(DestinationPath As String, FileName As String, RevisionDate As String, DocumentNumber As String)
Dim Cnt As Integer
Dim wsSV As Worksheet
Dim rng As Range
On Error GoTo ErrorHandler:
Set wsSV = Worksheets("DocumentList")
Cnt = 0
Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
Set rng = wsSV.Range("A" & Cnt + 1)
wsSV.Range("A" & Cnt + 1) = DestinationPath & FileName
wsSV.Range("B" & Cnt + 1) = FileName
wsSV.Range("C" & Cnt + 1) = RevisionDate
wsSV.Range("D" & Cnt + 1) = DocumentNumber
wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), DestinationPath
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "ErrorWrite"
End Sub
1. uses cell information (in sheet 2) to create a directory folder structure
2. uses cell information to place the correct file to the correct foolder (that was previously created)
3. renames the files when 255 characters are exceeded
4. when there are both native files (i.e. excel, word, autocad) and pdf files of the same file these are place in sheet 3 (named attachments)
5. Creates a hyperlink in the forth tab when the files have been moved succesfully
6. the excel
I need your help for the following because i have no clue where to start from
The above is an everyday task and i need a new excel to be generated everytime new documents are received and placed to the right place, with the exact format of the Sheet2 and sheet 3 (attachments) that will have all the past and present files with the addition of a hyperlink to the last column
Public CopyingFilesNo As IntegerPublic Function IsFolderExists(txt As String) As Boolean
'returns true if the folder exists already, false if it does not.
IsFolderExists = CreateObject("Scripting.FileSystemObject").FolderExists(txt)
End Function
Sub file_move()
On Error GoTo ErrorHandler:
Dim myFile As String
Dim myPath As String 'folder to test
Dim myPaths 'to check each folder in the destination path
Dim i As Long, j As Integer, CountF As Integer
Dim ws As Worksheet 'sheet with data
Dim wsSV As Worksheet 'sheet to update
Dim lr As Long 'last row with data
Dim baseFolder As String
Dim SourceFolder As String
Dim Folder1 As String
Dim TempFolder As String
Dim Folder2 As String
Dim Folder2Plus As String
Dim tempFolderTwo As String
Dim subFolderTwo As String
Dim Folder3 As String
Dim Folder3Plus As String
Dim tempFolderThree As String
Dim subFolderThree As String
Dim Folder4 As String
Dim Folder4Plus As String
Dim tempFolderFour As String
Dim subFolderFour As String
Dim FileName As String
Dim FIleNameNew As String
Dim FileNameFinal As String
Dim CheckString As String
Dim Cnt As Integer
Dim rng As Range
baseFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE\"
SourceFolder = "W:\GR-IPP_II\03. Procurement\03. EQUIPMENT\GE"
Set ws = Worksheets("Sheet2") 'change sheet name as needed
Set wsSV = Worksheets("DocumentList")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
Cnt = 1
CopyingFilesNo = 0
For i = 2 To lr
'Update*******************************************
Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
Set rng = wsSV.Range("A" & Cnt + 1)
'*************************************************
myPath = Replace(ws.Range("C" & i).Value, "/", "-")
myPaths = Split(myPath, "\")
myPath = vbNullString
Folder1 = Trim(ws.Range("A" & i).Value)
Dim fso As New FileSystemObject
If fso.FolderExists(baseFolder + Folder1) = False Then
fso.CreateFolder baseFolder + "" + Folder1
End If
'*********************************
Folder2 = Replace(ws.Range("c" & i).Value, "/", "")
Folder2Plus = Replace(ws.Range("d" & i).Value, "/", "")
tempFolderTwo = Trim(Folder2) + " " + Trim(Folder2Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo)
End If
'************************************************************************
Folder3 = Replace(ws.Range("e" & i).Value, "/", "")
Folder3Plus = Replace(ws.Range("f" & i).Value, "/", "")
tempFolderThree = Trim(Folder3) + " " + Trim(Folder3Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree)
End If
'************************************************************************
Folder4 = Replace(ws.Range("g" & i).Value, "/", "")
Folder4Plus = Replace(ws.Range("h" & i).Value, "/", "")
tempFolderFour = Trim(Folder4) + " " + Trim(Folder4Plus)
If fso.FolderExists(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour) = False Then
fso.CreateFolder (baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour)
End If
'************************************************************************
FileName = Replace(ws.Range("AE" & i).Value, "/", "")
CheckString = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FileName
If Len(CheckString) > 255 Then
Dim diff As Integer
diff = Len(CheckString) - 255
If fso.FileExists(SourceFolder + "\" + FileName) = True Then
FIleNameNew = Mid(FileName, 1, Len(FileName) - 5 - diff) + Mid(FileName, Len(FileName) - 4, 5)
fso.MoveFile SourceFolder + "\" + FileName, SourceFolder + "\" + FIleNameNew
FileNameFinal = baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\" + FIleNameNew
Call CopyFiles(SourceFolder, FIleNameNew, FileNameFinal)
wsSV.Range("A" & Cnt + 1) = FileNameFinal
wsSV.Range("B" & Cnt + 1) = FileName
wsSV.Range("C" & Cnt + 1) = ws.Range("v" & i).Value
wsSV.Range("D" & Cnt + 1) = ws.Range("t" & i).Value
wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), FileNameFinal
End If
Else
FileNameFinal = CheckString
'Call fso.CopyFile(SourceFolder + "\" + FileName, FileNameFinal, True)
If CopyFiles(SourceFolder, FileName, FileNameFinal) = True Then
ws.Range("AZ" & i).Value = True
Call WriteToDocumentList(baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", FileName, ws.Range("v" & i).Value, ws.Range("t" & i).Value)
End If
End If
'**********************************
If (ws.Range("af" & i).Value) <> 0 Then
CountF = 1
For CountF = 1 To ws.Range("af" & i).Value
Call AddAttachments(ws.Range("t" & i).Value, CountF, baseFolder + Folder1 + "\" + tempFolderTwo + "\" + tempFolderThree + "\" + tempFolderFour + "\", SourceFolder)
Next CountF
End If
Next i
MsgBox "FILES COPIED:" & CopyingFilesNo & " Files", vbInformation
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileName & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorInput"
End Sub
Private Function AddAttachments(FileIndex As String, Current As Integer, FileDestination As String, SourceFolder As String) As Boolean
On Error GoTo ErrorHandler:
Dim wsAtcm As Worksheet
Dim lRow As Long
Dim rangeAtcm As Range
Dim FoundCell As Range
Dim FileNametcm As String
Dim wsSV As Range
' Set wsSV = Worksheets("DocumentList")
Set wsAtcm = Worksheets("Attachments")
Set rangeAtcm = wsAtcm.Range("A1")
Set FoundCell = wsAtcm.Range("B:B").Find(what:=FileIndex, lookat:=xlWhole)
FileNametcm = rangeAtcm.Range("I" & FoundCell.Row).Value
rangeAtcm.Range("B" & FoundCell.Row).Value = rangeAtcm.Range("B" & FoundCell.Row).Value & " Copied"
Call CopyFiles(SourceFolder, FileNametcm, FileDestination & FileNametcm)
Call WriteToDocumentList(FileDestination, FileNametcm, rangeAtcm.Range("D" & FoundCell.Row).Value, FileIndex)
AddAttachments = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileNametcm & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorAttachm"
End Function
Private Function CopyFiles(SourcePath As String, FileName As String, DestinationPath As String) As Boolean
Dim fso As New FileSystemObject
Dim NewStringSource As String
Dim NewDestinationPath As String
On Error GoTo ErrorHandler:
NewStringSource = SourcePath + "\" + FileName
NewDestinationPath = DestinationPath
If InStr(SourcePath + "\" + FileName, "®") Then
NewStringSource = Replace(SourcePath + "\" + FileName, "®", "")
fso.MoveFile SourcePath + "\" + FileName, NewStringSource
NewDestinationPath = Replace(DestinationPath, "®", "")
End If
Call fso.CopyFile(NewStringSource, NewDestinationPath, True)
fso.DeleteFile (NewStringSource)
CopyingFilesNo = CopyingFilesNo + 1
CopyFiles = True
Exit Function
ErrorHandler:
MsgBox Err.Number & vbCrLf & FileName & vbCrLf & vbCrLf & DestinationPath & vbCrLf & Err.Description, vbCritical, "ErrorcOPYING"
End Function
Private Sub WriteToDocumentList(DestinationPath As String, FileName As String, RevisionDate As String, DocumentNumber As String)
Dim Cnt As Integer
Dim wsSV As Worksheet
Dim rng As Range
On Error GoTo ErrorHandler:
Set wsSV = Worksheets("DocumentList")
Cnt = 0
Cnt = Worksheets("DocumentList").UsedRange.Rows.Count
Set rng = wsSV.Range("A" & Cnt + 1)
wsSV.Range("A" & Cnt + 1) = DestinationPath & FileName
wsSV.Range("B" & Cnt + 1) = FileName
wsSV.Range("C" & Cnt + 1) = RevisionDate
wsSV.Range("D" & Cnt + 1) = DocumentNumber
wsSV.Hyperlinks.Add wsSV.Range("A" & Cnt + 1), DestinationPath
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "ErrorWrite"
End Sub