Error with code

[nitro2481]

Hi Guys,

I have had this question on Exel Help Forum for a while now but noone seems to be able to help me. Hoping someone here might.http://www.excelforum.com/showthread.php?t=1140272

I have a lot of code in my workbook all done with help from this forum. I am really not very knowledgeable with it and would love a bit of guidance with the following errors. I am attaching 3 codes. 1. This workbook, 2. Sheet 1 & 3. Sheet 2. Sheet 1 seems to work perfect but with the same code in sheet 3 its not working as well.
Problem 1: I have sheet 1 & 2 set up so that in column E all the text defaults to proper text as in names should start with capitals. This is working fine in sheet 1 but not in sheet 2 for some reason and the code seems to be identical. Also there seems to be a problem selecting cells in sheet 2 but not
sheet 1. I can select a cell and alter it but it is not highlighted on excel and also i cannot tab or scroll through the cells I can just click on them to alter them

Problem 2: I have a code in Sheet 1 & 2 that if there is anything input in Cell D then the date appears in cell 4. This works if I manually type in Cell D but as you can see I also have a code that depending on certain triggers, information auto transfers to sheets 1 & 2 however when this happens the date does not populate in A? Also I was hoping that if the entry in D was then deleted cell A would automatically delete

Would really appreciate your help with this.

This workbook code

Option Explicit
Option Compare Text
Dim ws As Worksheet
Const MaxUses As Long = 5   '<- change uses
Const wsWarningSheet As String = "Splash"


Private Type mySheetVisibilityStructure
  sSheetName As String
  iVisibility As Long
End Type


Private bGblDoNotCancelIfCalledFromCloseEvent As Boolean


Const sSheetNameThatMUST_REMAIN_VISIBLE = "Splash"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)


  Dim wks As Worksheet
  Dim mySheetVisibilityStructureArray() As mySheetVisibilityStructure
  Dim i As Long
  Dim iVisibility As Long
  Dim iVisibilityErrorSheet As Long
  Dim sActiveSheetName As String
  Dim sErrorSheetName As String
  Dim sSheetName As String
  
  'Initialize the 'Sheet Visibiilty Structure Array'
  ReDim mySheetVisibilityStructureArray(1 To 1)
  
  'Save the 'Active Sheet' Name
  sActiveSheetName = ActiveSheet.Name
  
  'Verify that the 'Master Sheet' exists
  On Error Resume Next
  iVisibility = Sheets(sSheetNameThatMUST_REMAIN_VISIBLE).Visible
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox "SAVE NOT DONE.  Data Integrity Error." & vbCrLf & _
           "In order to save this file Sheet '" & sSheetNameThatMUST_REMAIN_VISIBLE & "' MUST EXIST." & vbCrLf & vbCrLf & _
           "WARNING.  If this condition is NOT CORRECTED, Data may be LOST."
    Cancel = True   'Cancel Save
    On Error GoTo 0
    Exit Sub
  End If
  On Error GoTo 0
  
  'Disable 'Screen Updating' to eliminate Screen Flicker
  Application.ScreenUpdating = False
  
  'Save the 'Visibility of Each Sheet'
  'Make all Sheets Hidden Except the 'Master Sheet'
  For Each wks In ThisWorkbook.Sheets
      'Add an element to the 'Sheet Visibiilty Structure Array'
      'Put the 'Sheet Name' and the 'Sheet Visibility' in the Array
      i = i + 1
      ReDim Preserve mySheetVisibilityStructureArray(1 To i)
      mySheetVisibilityStructureArray(i).sSheetName = wks.Name
      mySheetVisibilityStructureArray(i).iVisibility = wks.Visible
      
    'Make the 'Master Sheet' visible and the Active Sheet
    'Hide All other Sheets
    If UCase(wks.Name) = UCase(sSheetNameThatMUST_REMAIN_VISIBLE) Then
      'Make the 'Master Sheet' visible and make the 'Master Sheet' the 'Active Sheet'
      wks.Visible = xlSheetVisible
      wks.Activate
    Else
      'Hide all other Sheets
      wks.Visible = xlSheetVeryHidden  'Can be 'xlSheetHidden' or 'xlSheetVeryHidden'
    End If
  
  Next wks
  
  'Turn Off Excel Events
  Application.EnableEvents = False
  


  'Save this file
  ThisWorkbook.Save
  
'Cancel command removed from here and moved to the bottom of the routine




  'Restore Original Sheet Visibility
  For i = LBound(mySheetVisibilityStructureArray) To UBound(mySheetVisibilityStructureArray)
    sSheetName = mySheetVisibilityStructureArray(i).sSheetName
    iVisibility = mySheetVisibilityStructureArray(i).iVisibility
    
    'A runtime error will occur if Excel attempt to hide all Sheets
    On Error Resume Next
    Sheets(sSheetName).Visible = iVisibility
    If Err.Number = 1004 Then
      Err.Clear
      sErrorSheetName = sSheetName
      iVisibilityErrorSheet = iVisibility
    End If
    On Error GoTo 0
  Next i
  
  'If a Sheet had a runtime error - restore it's original visibility
  If Len(sErrorSheetName) > 0 Then
    Sheets(sErrorSheetName).Visible = iVisibilityErrorSheet
  End If
  
  'Resume with the 'Original Active Sheet'
  Sheets(sActiveSheetName).Activate
  
  'Turn On Excel Events
  'Turn On Screen Updating
  Application.EnableEvents = True
  Application.ScreenUpdating = True




 


    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    
  
  'Cancel Save - to prevent recursion
  If bGblDoNotCancelIfCalledFromCloseEvent = True Then
    'Do nothing - Prevent Cancel
  ElseIf SaveAsUI = True Then
    'Do nothing - Prevent Cancel - Allow Save As Dialog Box
  Else
    Cancel = True
  End If
  
  'Reset the Global Called From Save Event Flag
  bGblDoNotCancelIfCalledFromCloseEvent = False
End Sub
Public Sub MakeAllSheetsVisible()
  Dim wks As Worksheet
  For Each wks In ThisWorkbook.Sheets
    wks.Visible = xlSheetVisible
  Next wks
End Sub
Private Sub Workbook_Open()
  For Each ws In ThisWorkbook.Sheets
        If ws.Name = wsWarningSheet Then
            ws.Visible = True
        Else
            ws.Visible = xlVeryHidden
        End If
    Next
    
    'record opening in remote cell
    With Sheets(wsWarningSheet).Cells(Rows.Count, Columns.Count)
      
    End With


Const sHide2 As String = "AA:AA, Ak:Ak, Ap:Ap, AQ:AQ, Av:Av, Aw:Aw, Bb:Bb, Bc:Bc, Bh:Bh, Bi:Bi, Bn:Bn, Bo:Bo, Bt:Bt, Bu:Bu, Bz:Bz, ca:ca "
Const sHide4 As String = "I:I, O:O"
Const sHide5 As String = "j:j, o:o"


With Sheet2
    Application.EnableEvents = False
    .Cells(1, 36).ClearContents
    Application.EnableEvents = True
    .Unprotect
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With


With Sheet4
    Application.EnableEvents = False
    .Cells(2, 16).ClearContents
    Application.EnableEvents = True
    .Unprotect
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With


With Sheet5
    Application.EnableEvents = False
    .Cells(1, 17).ClearContents
    Application.EnableEvents = True
    .Unprotect
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With


     UserForm1.Show


  'Enable Timers on Workbook Open
  bGblInhibitTimers = False


  'Stop all timers
  On Error Resume Next
  Application.OnTime RunWhen, "SaveAndClose", , False
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
 
  'Arm Timer to save and close workbook
  RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
  Application.OnTime RunWhen, "SaveAndClose", , True


  'Arm Timer to display time remaining
  RunStatusBarWhen = Now + TimeSerial(0, 0, STATUS_BAR_REFRESH_TIME_IN_SECONDS)
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , True


   
  
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    
    'Display Time Remaining Only When timers are enabled
    If bGblInhibitTimers = False Then
      RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
      Application.OnTime RunWhen, "SaveAndClose", , True
    End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
    ByVal Target As Range)


    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    
    On Error GoTo 0
    'Display Time Remaining Only When timers are enabled
    If bGblInhibitTimers = False Then
      RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
      Application.OnTime RunWhen, "SaveAndClose", , True
    End If


End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)


' Hide all sheets except the splash sheet
SHideAllSheets
'Stop all timers
  On Error Resume Next
  Application.OnTime RunWhen, "SaveAndClose", , False
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
  
  'Disable 'Save Cancel' if Called from Here
  bGblDoNotCancelIfCalledFromCloseEvent = True


  'Clear the Status Bar
  Application.StatusBar = ""


End Sub
Sub SHideAllSheets()


Dim ws As Worksheet
' global constant
' Const wsWarningSheet As String = "Splash"


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False


For Each ws In ThisWorkbook.Sheets
    If ws.Name = wsWarningSheet Then
        ws.Visible = True
    Else
        ws.Visible = xlVeryHidden
    End If
Next


ThisWorkbook.Save




Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

 

[nitro2481]

Sheet 1 code

Option Explicit
Option Compare Text
Dim rw As Long
Dim thisrow As Long
Dim c As Excel.Range
Dim str              As String
Dim v                As Variant
Dim iStart           As Integer
Dim iEnd             As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Const sPW As String = "$P$2"
Const sHide As String = "I:I, O:O"
If Not Intersect(Target, Range(sPW)) Is Nothing Then
    If Target.Value = 1234 Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = False
        Range(sHide).EntireColumn.Hidden = False
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    ElseIf Target.Value = "" Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = True
        Range(sHide).EntireColumn.Hidden = True
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    End If
    End If
   Application.EnableEvents = False
   On Error GoTo Catch
    
    
    With Target
    Select Case True
Case .Column = 4
            Range("A" & Target.Row) = Date


         Case Not Intersect(Target, Range("E4:E500")) Is Nothing


            For Each c In Intersect(Target, Range("E4:E500"))


               ' don't process - just remove the .
               If Left(c.Value, 1) = "~" Then
                  str = Mid(c.Value, 2)
               Else
                  str = StrConv(c.Value, vbProperCase)


                  ' O'Leary, D'Alton,A'Courcey, N'Dou, De'Ath (really!)


                  If InStr(str, "o'") > 0 Or _
                     InStr(str, "d'") > 0 Or _
                     InStr(str, "a'") > 0 Or _
                     InStr(str, "n'") > 0 Or _
                     InStr(str, "de'") > 0 Then


                     iStart = InStr(str, "'") - 1
                     str = Left(str, iStart) & "'" & StrConv(Mid(str, iStart + 2), vbProperCase)
                  End If


                  ' von Adler, van Dieman
                  If InStr(str, " von ") > 0 Or InStr(str, " van ") > 0 Then
                     iStart = InStr(str, " v") - 1
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1, 4), vbLowerCase) & Mid(str, iStart + 5)
                  End If


                  ' von der Recke - but the von has already been handled. 1 of the reasons this is not a 'Select Case' block
                  If InStr(str, " der ") > 0 Then
                     iStart = InStr(str, " der ") - 1
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1, 4), vbLowerCase) & Mid(str, iStart + 5)
                  End If


                  ' Hyphenated
                  If InStr(str, "-") > 0 Then


                     ' Ignore if spaced already
                     If Mid(str, iStart + 2) <> " " Then
                        iStart = InStr(str, "-") - 1
                        str = Left(str, iStart) & "-" & StrConv(Mid(str, iStart + 2), vbProperCase)
                     End If
                  End If


                  ' Let's just include a Mc
                  If InStr(str, " mc") > 0 Then
                     iStart = InStr(str, " mc") + 2
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1), vbProperCase)
                  End If


                  ' Never mind the de la, della and about 20 others but getting vanishingly small in numbers
               End If
               c.Value = str
            Next


      End Select


   End With


Catch:


   Application.EnableEvents = True


End Sub
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveSheet.Unprotect
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells


End Sub

Sheet 2 code

Option Explicit
Option Compare Text
Dim rw As Long
Dim thisrow As Long
Dim c As Excel.Range
Dim str              As String
Dim v                As Variant
Dim iStart           As Integer
Dim iEnd             As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Const sPW As String = "$P$1"
Const sHide As String = "I:I, N:N"
If Not Intersect(Target, Range(sPW)) Is Nothing Then
    If Target.Value = 1234 Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = False
        Range(sHide).EntireColumn.Hidden = False
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    ElseIf Target.Value = "" Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = True
        Range(sHide).EntireColumn.Hidden = True
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    End If
    End If
   Application.EnableEvents = False
   On Error GoTo Catch
    
    
    With Target
    Select Case True
Case .Column = 4
            Range("A" & Target.Row) = Date


         Case Not Intersect(Target, Range("D4:D500")) Is Nothing


            For Each c In Intersect(Target, Range("D4:D500"))


               ' don't process - just remove the .
               If Left(c.Value, 1) = "~" Then
                  str = Mid(c.Value, 2)
               Else
                  str = StrConv(c.Value, vbProperCase)


                  ' O'Leary, D'Alton,A'Courcey, N'Dou, De'Ath (really!)


                  If InStr(str, "o'") > 0 Or _
                     InStr(str, "d'") > 0 Or _
                     InStr(str, "a'") > 0 Or _
                     InStr(str, "n'") > 0 Or _
                     InStr(str, "de'") > 0 Then


                     iStart = InStr(str, "'") - 1
                     str = Left(str, iStart) & "'" & StrConv(Mid(str, iStart + 2), vbProperCase)
                  End If


                  ' von Adler, van Dieman
                  If InStr(str, " von ") > 0 Or InStr(str, " van ") > 0 Then
                     iStart = InStr(str, " v") - 1
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1, 4), vbLowerCase) & Mid(str, iStart + 5)
                  End If


                  ' von der Recke - but the von has already been handled. 1 of the reasons this is not a 'Select Case' block
                  If InStr(str, " der ") > 0 Then
                     iStart = InStr(str, " der ") - 1
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1, 4), vbLowerCase) & Mid(str, iStart + 5)
                  End If


                  ' Hyphenated
                  If InStr(str, "-") > 0 Then


                     ' Ignore if spaced already
                     If Mid(str, iStart + 2) <> " " Then
                        iStart = InStr(str, "-") - 1
                        str = Left(str, iStart) & "-" & StrConv(Mid(str, iStart + 2), vbProperCase)
                     End If
                  End If


                  ' Let's just include a Mc
                  If InStr(str, " mc") > 0 Then
                     iStart = InStr(str, " mc") + 2
                     str = Left(str, iStart) & StrConv(Mid(str, iStart + 1), vbProperCase)
                  End If


                  ' Never mind the de la, della and about 20 others but getting vanishingly small in numbers
               End If
               c.Value = str
            Next


      End Select


   End With


Catch:


   Application.EnableEvents = True


End Sub
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveSheet.Unprotect
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells


End Sub