neomapper1
New Member
- Joined
- Jul 1, 2021
- Messages
- 2
- Office Version
- 2019
- Platform
- Windows
Is there a simple way to clean up a previous file location when a worksheet_Change gets activated when someone changes a dropdown value for an office? Our script creates a directory when an office dropdown gets set. We are having trouble with people assigning the wrong office which is getting saved to the wrong file locations.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'updateby neomapper1
Dim path As String
Dim Filename As String
Dim Office As String
Dim HouseNo As String
Dim Street As String
Dim Unit As String
Dim URL As String
Dim CloudStrasburg As String
Dim CloudLancaster As String
Dim CloudMentor As String
Dim InStr As String
Dim strReplaceURL As String
Dim ResultURL As String
Dim strReplace As String
Dim Result As String
' Cloud Path Varibles
CloudLancaster = "https://egas.egnyte.com/app/index.do#storage/files/1/Shared/Enterprise%20File%20Shares/NEO_Assignments/2021%20Work%20Orders/1)%20Lancaster%20Office/0_Service_Request/"
CloudStrasburg = "https://egas.egnyte.com/app/index.do#storage/files/1/Shared/Enterprise%20File%20Shares/NEO_Assignments/2021%20Work%20Orders/2)%20Strasburg%20Office/0_Service_Request/"
CloudMentor = "https://egas.egnyte.com/app/index.do#storage/files/1/Shared/Enterprise%20File%20Shares/NEO_Assignments/2021%20Work%20Orders/3)%20Mentor%20Office/0_Service_Request/"
' Lancaster Filing Code
If Not Intersect(Target, Range("AA3")) Is Nothing Then
If InStr(1, Target.Value, "Lancaster") > 0 Then
If Target <> olval Then
' Step 1
' Remove any double space before pulling the name
Call RemoveAdditionalSpaces
' Step 2
' Capture cell values for Directory & File Name
Office = Range("AA3").Value
HouseNo = Range("A5").Value
Street = Range("G4").Value
Unit = Range("S5").Value
Application.EnableEvents = False
Filename = Format(Range("G4"), "[COLOR=#ff0000]dd-mm-yyyy[/COLOR]")
olval = Filename
path = "Z:\Shared\Enterprise File Shares\NEO_Assignments\2021 Work Orders\1) Lancaster Office\0_Service_Request\"
If IsEmpty(Range("S5").Value) = True Then
'MsgBox "Unit# Is Empty..."
URL = path & Office & " - " & HouseNo & " " & Street
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & ".xls"
'URL & "/" & Office & " - " & HouseNo & " " & Filename & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below to the star where it says field Paperwork link.", "APP-AFE Egnyte URL", CloudLancaster & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
If IsEmpty(Range("S5").Value) = False Then
'MsgBox "Unit# Exists..."
URL = path & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below To the star where it says field Paperwork Link.", "APP-AFE Egnyte URL", CloudLancaster & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
Application.EnableEvents = True
End If
End If
End If
' Strasburg Filing Code
If Not Intersect(Target, Range("AA3")) Is Nothing Then
If InStr(1, Target.Value, "Strasburg") > 0 Then
If Target <> olval Then
' Step 1
' Remove any double space before pulling the name
Call RemoveAdditionalSpaces
' Step 2
' Capture cell values for Directory & File Name
Office = Range("AA3").Value
HouseNo = Range("A5").Value
Street = Range("G4").Value
Unit = Range("S5").Value
Application.EnableEvents = False
Filename = Format(Range("G4"), "[COLOR=#ff0000]dd-mm-yyyy[/COLOR]")
olval = Filename
path = "Z:\Shared\Enterprise File Shares\NEO_Assignments\2021 Work Orders\2) Strasburg Office\0_Service_Request\"
If IsEmpty(Range("S5").Value) = True Then
'MsgBox "Unit# Is Empty..."
URL = path & Office & " - " & HouseNo & " " & Street
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & ".xls"
'URL & "/" & Office & " - " & HouseNo & " " & Filename & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below To the star where it says field Paperwork Link.", "APP-AFE Egnyte URL", CloudStrasburg & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
If IsEmpty(Range("S5").Value) = False Then
'MsgBox "Unit# Exists..."
URL = path & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below To the star where it says field Paperwork Link.", "APP-AFE Egnyte URL", CloudStrasburg & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
Application.EnableEvents = True
End If
End If
End If
' Mentor Filing Code
If Not Intersect(Target, Range("AA3")) Is Nothing Then
If InStr(1, Target.Value, "Mentor") > 0 Then
If Target <> olval Then
' Step 1
' Remove any double space before pulling the name
Call RemoveAdditionalSpaces
' Step 2
' Capture cell values for Directory & File Name
Office = Range("AA3").Value
HouseNo = Range("A5").Value
Street = Range("G4").Value
Unit = Range("S5").Value
Application.EnableEvents = False
Filename = Format(Range("G4"), "[COLOR=#ff0000]dd-mm-yyyy[/COLOR]")
olval = Filename
path = "Z:\Shared\Enterprise File Shares\NEO_Assignments\2021 Work Orders\3) Mentor Office\0_Service_Request\"
If IsEmpty(Range("S5").Value) = True Then
'MsgBox "Unit# Is Empty..."
URL = path & Office & " - " & HouseNo & " " & Street
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & ".xls"
'URL & "/" & Office & " - " & HouseNo & " " & Filename & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below To the star where it says field Paperwork Link.", "APP-AFE Egnyte URL", CloudMentor & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
If IsEmpty(Range("S5").Value) = False Then
'MsgBox "Unit# Exists..."
URL = path & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
strFolderExists = URL & "\"
'MsgBox strFolderExists
If Dir(strFolderExists) = "" Then
'MsgBox "The selected folder doesn't exist"
MkDir URL
ActiveWorkbook.SaveAs Filename:=URL & "\" & Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit & ".xls"
strReplace = Office & " - " & HouseNo & " " & Filename & " Unit# " & Unit
Result = Replace(strReplace, " ", "%20")
InputBox "Copy And paste the URL below To the star where it says field Paperwork Link.", "APP-AFE Egnyte URL", CloudMentor & Result
Else
MsgBox "The selected folder exists"
Call ClearMerged
Application.EnableEvents = True
End If
End If
Application.EnableEvents = True
End If
End If
End If
End Sub
Sub RemoveAdditionalSpaces()
Range("G4") = Application.WorksheetFunction.Trim(Range("G4"))
Range("A5") = Application.WorksheetFunction.Trim(Range("A5"))
Range("S5") = Application.WorksheetFunction.Trim(Range("S5"))
End Sub
Sub ClearMerged()
Call RemoveAdditionalSpaces
'updateby neomapper1
Dim Rg As Range, Rg1 As Range
Dim xAddress As String
On Error Resume Next
xAddress = "$AA$3"
Set Rg = Application.InputBox("Please update the Unit # And reassign an office.", "APP-AFE Alert", xAddress, , , , , 8)
If Rg Is Nothing Then Exit Sub
For Each Rg1 In Rg
If Rg1.MergeCells Then Rg1.MergeArea.ClearContents
Next
Call RemoveAdditionalSpaces
End Sub
