Fix Code Issues

R

RandyD123

Active Member
Joined
Dec 4, 2013
Messages
296
Office Version
  1. 2016
Platform
  1. Windows
All, I have the following code and there is one line in it that needs to be changed, but I'm not sure how to fix it without breaking it!!!

VBA Code: 
Sub CreateA()
    On Error GoTo ErrorHandler:
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .StatusBar = "Creating Amended.  Please wait..."
    End With
    If ActiveWorkbook.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "AM" Or ActiveWorkbook.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "PM" Then
        If ActiveWorkbook.ReadOnly = True Then MsgBox "The Initials were open as 'Read-Only.'  Please open them as NOT 'Read-Only' and try again!", 16, "Initials Read-Only": GoTo Cleanup
        myDate = Range("F1").Value
        newLine = Chr(10) & Chr(13)
        response1 = MsgBox(" Are you sure you want to create the 'Amended' for " & Format(myDate, "mm/dd/yy") & "?" & _
            newLine & " If so, the following will occur:" & _
            newLine & " -  the 'Initials' will be saved" & _
            newLine & " -  the 'Amended' will be created at a location of your choosing", 292, "Create Amended")
        If response1 = 7 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
        response2 = MsgBox(" Would you like to save the 'Amended' to the 'Amended' folder?" & _
            newLine & " -  click 'Yes' for the 'Amended' folder" & _
            newLine & " -  click 'No' to save to your Desktop" & _
            newLine & " -  click 'Cancel' to cancel this process", 547, "Location")
        If response2 = 2 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
        If ActiveWorkbook.Saved = False Then ActiveWorkbook.Save
       [COLOR=rgb(0, 168, 133)] If Dir("\\airport.ishare.tsa.dhs.gov@SSL\DavWWWRoot\fieldlocations\MHT\soc\SOC Scheduling\Shared Documents\Amended\"[/COLOR] & Left(ActiveSheet.Name, 2) & _
            " Amended " & Format(myDate, "mm-dd-yy") & ".xlsm") <> "" Or Dir("C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(ActiveSheet.Name, 2) & _
            " Amended " & Format(myDate, "mm-dd-yy") & ".xlsm") <> "" Then MsgBox "The 'Amended' already exist in the 'Amended' folder or on your Desktop. " & _
            " Please remove and try again.  No 'Amended' was created.", 48, "File Already Exist": GoTo Cleanup
        Select Case response2
            Case 6
                ActiveWorkbook.SaveAs[COLOR=rgb(226, 80, 65)] Filename:="https://ustsa.sharepoint.com/sites/Airport-R1-MHT/soc/SOC Scheduling/Shared Documents/Amended/"[/COLOR] & _
                    Left(ActiveSheet.Name, 2) & " Amended " & Format(myDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
            Case 7
                ActiveWorkbook.SaveAs Filename:="C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(ActiveSheet.Name, 2) & _
                    " Amended " & Format(myDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
        End Select
        Application.DisplayAlerts = False
        For Each X In ActiveWorkbook.Sheets
            If X.Name <> ActiveSheet.Name And X.Name <> "Master Schedule" And X.Name <> "Audit" Then X.Delete
        Next X
        Range("F1").Value = myDate
        If Worksheets("Master Schedule").Visible = True Then Worksheets("Master Schedule").Visible = False
        Application.DisplayAlerts = True
        ActiveWorkbook.Save
        MsgBox "The 'Amended' was successfully created!", 64, "Amended Created"
    End If
Cleanup:
    With Application
        .EnableEvents = True
        .StatusBar = ""
    End With
Exit Sub
ErrorHandler:
    MsgBox "Error number '" & Err.Number & "' has occurred:" & newLine & newLine & _
        Err.Description & newLine & newLine & _
        "Please try again.  If the error persists, please contact Patrick Dunn for assistance.", 16, "Error Occurred"
    GoTo Cleanup
End Sub

The Directory line in green no longer exists. That IShare site has been removed. But the line in Red does exist. So what I need my code to do is check that site on OneDrive and if my file already exists, then it won't let me create another copy. Just like it does for the desktop. Basically the code checked 2 places to see if the file i'm creating already exists and if it did, then the code would error out. So I'm just not sure how to fix the IfDIR line?

Thanks in advance
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
Hi RandyD123,

if you want to color codelines or fragments you should use the Rich-Codetags instead of VBA.

Maybe

VBA Code: 
Sub CreateA()
' https://www.mrexcel.com/board/threads/fix-code-issues.1232797/
  Dim wbAct As Workbook
  Dim response1 As Long
  Dim response2 As Long
  Dim X As Worksheet
  Dim wsAct As Worksheet
  Dim MyDate As Date
  
  Const cstrShareP As String = "https://ustsa.sharepoint.com/sites/Airport-R1-MHT/soc/SOC Scheduling/Shared Documents/Amended/"
  
  On Error GoTo ErrorHandler
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .StatusBar = "Creating Amended.  Please wait..."
  End With
  
  Set wbAct = ActiveWorkbook
  If wbAct.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "AM" Or _
      wbAct.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "PM" Then
    If wbAct.ReadOnly = True Then MsgBox "The Initials were open as 'Read-Only.'  Please open them as NOT 'Read-Only' and try again!", 16, "Initials Read-Only": GoTo Cleanup
    
    Set wsAct = wbAct.ActiveSheet
    MyDate = wsAct.Range("F1").Value
    response1 = MsgBox(" Are you sure you want to create the 'Amended' for " & Format(MyDate, "mm/dd/yy") & "?" & _
        vbCrLf & " If so, the following will occur:" & _
        vbCrLf & " -  the 'Initials' will be saved" & _
        vbCrLf & " -  the 'Amended' will be created at a location of your choosing", 292, "Create Amended")
    If response1 = 7 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
    
    response2 = MsgBox(" Would you like to save the 'Amended' to the 'Amended' folder?" & _
        vbCrLf & " -  click 'Yes' for the 'Amended' folder" & _
        vbCrLf & " -  click 'No' to save to your Desktop" & _
        vbCrLf & " -  click 'Cancel' to cancel this process", 547, "Location")
    If response2 = 2 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
    
    If wbAct.Saved = False Then wbAct.Save
    If Dir(cstrShareP & Left(wsAct.Name, 2) & _
        " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm") <> "" Or Dir("C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(wsAct.Name, 2) & _
        " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm") <> "" Then MsgBox "The 'Amended' already exist in the 'Amended' folder or on your Desktop. " & _
        " Please remove and try again.  No 'Amended' was created.", 48, "File Already Exist": GoTo Cleanup
    Select Case response2
        Case 6
          wbAct.SaveAs Filename:=cstrShareP & _
              Left(wsAct.Name, 2) & " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
        Case 7
          wbAct.SaveAs Filename:="C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(wsAct.Name, 2) & _
              " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
    End Select
    
    Application.DisplayAlerts = False
    
    For Each X In wbAct.Sheets
      If X.Name <> wsAct.Name And X.Name <> "Master Schedule" And X.Name <> "Audit" Then X.Delete
    Next X
    
    'not so sure on which sheet thos shoud be placed
    Range("F1").Value = MyDate
    If Worksheets("Master Schedule").Visible = True Then Worksheets("Master Schedule").Visible = False
    
    Application.DisplayAlerts = True
    wbAct.Save
    MsgBox "The 'Amended' was successfully created!", 64, "Amended Created"
  End If

Cleanup:
  With Application
    .EnableEvents = True
    .StatusBar = ""
  End With
  Set wsAct = Nothing
  Set wbAct = Nothing
  Exit Sub

ErrorHandler:
  MsgBox "Error number '" & Err.Number & "' has occurred:" & vbCrLf & vbCrLf & _
      Err.Description & vbCrLf & vbCrLf & _
      "Please try again.  If the error persists, please contact Patrick Dunn for assistance.", 16, "Error Occurred"
  GoTo Cleanup

End Sub

Ciao,
Holger
 
Upvote 0
HaHoBe said:
Hi RandyD123,

if you want to color codelines or fragments you should use the Rich-Codetags instead of VBA.

Maybe

VBA Code: 
Sub CreateA()
' https://www.mrexcel.com/board/threads/fix-code-issues.1232797/
  Dim wbAct As Workbook
  Dim response1 As Long
  Dim response2 As Long
  Dim X As Worksheet
  Dim wsAct As Worksheet
  Dim MyDate As Date
 
  Const cstrShareP As String = "https://ustsa.sharepoint.com/sites/Airport-R1-MHT/soc/SOC Scheduling/Shared Documents/Amended/"
 
  On Error GoTo ErrorHandler
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .StatusBar = "Creating Amended.  Please wait..."
  End With
 
  Set wbAct = ActiveWorkbook
  If wbAct.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "AM" Or _
      wbAct.Name Like "Initials*" And Left(ActiveSheet.Name, 2) = "PM" Then
    If wbAct.ReadOnly = True Then MsgBox "The Initials were open as 'Read-Only.'  Please open them as NOT 'Read-Only' and try again!", 16, "Initials Read-Only": GoTo Cleanup
 
    Set wsAct = wbAct.ActiveSheet
    MyDate = wsAct.Range("F1").Value
    response1 = MsgBox(" Are you sure you want to create the 'Amended' for " & Format(MyDate, "mm/dd/yy") & "?" & _
        vbCrLf & " If so, the following will occur:" & _
        vbCrLf & " -  the 'Initials' will be saved" & _
        vbCrLf & " -  the 'Amended' will be created at a location of your choosing", 292, "Create Amended")
    If response1 = 7 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
 
    response2 = MsgBox(" Would you like to save the 'Amended' to the 'Amended' folder?" & _
        vbCrLf & " -  click 'Yes' for the 'Amended' folder" & _
        vbCrLf & " -  click 'No' to save to your Desktop" & _
        vbCrLf & " -  click 'Cancel' to cancel this process", 547, "Location")
    If response2 = 2 Then MsgBox "The user cancelled this process.  No 'Amended' was created.", 48, "User Cancelled": GoTo Cleanup
 
    If wbAct.Saved = False Then wbAct.Save
    If Dir(cstrShareP & Left(wsAct.Name, 2) & _
        " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm") <> "" Or Dir("C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(wsAct.Name, 2) & _
        " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm") <> "" Then MsgBox "The 'Amended' already exist in the 'Amended' folder or on your Desktop. " & _
        " Please remove and try again.  No 'Amended' was created.", 48, "File Already Exist": GoTo Cleanup
    Select Case response2
        Case 6
          wbAct.SaveAs Filename:=cstrShareP & _
              Left(wsAct.Name, 2) & " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
        Case 7
          wbAct.SaveAs Filename:="C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(wsAct.Name, 2) & _
              " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm", ConflictResolution:=1
    End Select
 
    Application.DisplayAlerts = False
 
    For Each X In wbAct.Sheets
      If X.Name <> wsAct.Name And X.Name <> "Master Schedule" And X.Name <> "Audit" Then X.Delete
    Next X
 
    'not so sure on which sheet thos shoud be placed
    Range("F1").Value = MyDate
    If Worksheets("Master Schedule").Visible = True Then Worksheets("Master Schedule").Visible = False
 
    Application.DisplayAlerts = True
    wbAct.Save
    MsgBox "The 'Amended' was successfully created!", 64, "Amended Created"
  End If

Cleanup:
  With Application
    .EnableEvents = True
    .StatusBar = ""
  End With
  Set wsAct = Nothing
  Set wbAct = Nothing
  Exit Sub

ErrorHandler:
  MsgBox "Error number '" & Err.Number & "' has occurred:" & vbCrLf & vbCrLf & _
      Err.Description & vbCrLf & vbCrLf & _
      "Please try again.  If the error persists, please contact Patrick Dunn for assistance.", 16, "Error Occurred"
  GoTo Cleanup

End Sub

Ciao,
Holger
Click to expand...
So when I hit CTRL+S, nothing happens. It used to give me two options when i did that..... And if I manually run it, it errors out..... and says "bad file name"
 
Upvote 0
Hi RandyD123,

CTRL+s to my knowledge means saving the workbook. The code posted here has nothing to do with that shortcut so the reason for the Shortcut not working must be anywhere else.

And if I manually run it, it errors out..... and says "bad file name"
Click to expand...

At which codeline? Please remember: I don't have any information except from the code and what you tell me, and I'm afraid I can't build a system to test your code.

Holger
 
Upvote 0
HaHoBe said:
Hi RandyD123,

CTRL+s to my knowledge means saving the workbook. The code posted here has nothing to do with that shortcut so the reason for the Shortcut not working must be anywhere else.



At which codeline? Please remember: I don't have any information except from the code and what you tell me, and I'm afraid I can't build a system to test your code.

Holger
Click to expand...

Ok I understand that. What I am looking to do is JUST change the "If Dir ("\\airport.ishare.tsa.dhs.gov@SSL\DavWWWRoot\fieldlocations\MHT\soc\SOC Scheduling\Shared Documents\Amended\"...... so the code looks at https://ustsa.sharepoint.com/sites/Airport-R1-MHT/soc/SOC Scheduling/Shared Documents/Amended/ to see if the file already exists. The code works just fine except for what happens now is that if the file exists on my desktop, I get the msg box saying so. But if it already exists on the one drive site, it just overwrites it. Just need to change that one line so if it exists on one drive I get the msg box saying it already exists on my desktop or one drive
 
Upvote 0
Hi RandyD123,

if you start the code in step-mode what does the following codeline in the immediate window return:

VBA Code: 
?Dir("C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\Desktop\" & Left(wsAct.Name, 2) & " Amended " & Format(MyDate, "mm-dd-yy") & ".xlsm")

To get the path to my local OneDrive I use the following code

VBA Code: 
Function OneDrive_LocalFolder(Optional blnPersonal As Boolean = False, _
                              Optional blnInclLastPathSepChar As Boolean = True) As String
' updated 2020-06-22 by OPE
' returns the path to the local OneDrive folder, business or personal, returns an empty string if the folder doesn't exist
Dim strOneDrive     As String
Dim OK              As Boolean

On Error Resume Next
If blnPersonal Then
  strOneDrive = Environ("OneDriveConsumer") ' local path to the OneDrive Personal sync folder
Else
  strOneDrive = Environ("OneDriveCommercial") ' local path to the OneDrive Business sync folder
End If
'If Len(strOneDrive) = 0 Then strOneDrive = Environ("OneDrive") ' local path to the OneDrive sync folder
On Error GoTo 0
If Len(strOneDrive) = 0 Then Exit Function ' folder information not found

OK = False
On Error Resume Next
OK = Len(Dir(strOneDrive, vbDirectory)) <> 0 ' vbDirectory=16
On Error GoTo 0
If Not OK Then Exit Function ' folder doesn't exist

If blnInclLastPathSepChar Then ' add any missing last path separator char
  If Right(strOneDrive, 1) <> Application.PathSeparator Then strOneDrive = strOneDrive & Application.PathSeparator
Else ' remove any existing last path separator char
  If Right(strOneDrive, 1) = Application.PathSeparator Then strOneDrive = Left(strOneDrive, Len(strOneDrive) - 1)
End If
OneDrive_LocalFolder = strOneDrive
End Function

As mentioned I use a personal OneDrive, the function is called like
VBA Code: 
    OneDrive_LocalFolder(True, True)

Holger
 
Upvote 0
Thank you for all that helped. I got it. It took some time but in the end this is what I needed. "C:\Users\" & Environ("USERNAME") & "\OneDrive - USTSA\SCC Documents - Security Coordination Center\Amended\".......

Works perfectly.
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro to email Report
Replies
2
Views
549
howard
H
I
  • Question Question
Advice to remove old code for a new code
Replies
2
Views
202
ipbr21054
I
R
  • Question Question
Copy and Paste from one workbook to another...
Replies
6
Views
404
RandyD123
R
T
  • Solved
Kill Command should work according to everything I have read, but it doesn't
Replies
6
Views
431
Artik
Artik
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
100
brentcole
B

Forum statistics

Threads
1,223,897
Messages
6,175,270
Members
452,628
Latest member
dd2

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top