In VBA, which relates to the ability to sort/autofilter?

[TheJay]

I am using the following code:

Option Explicit

Private Sub Worksheet_Activate()
    Range("C4").Select
    With Worksheets("VO Areas")
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
    End With
    With Application
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End With
End Sub

I have three columns that I want to be able to use the dropdown list on to be able to sort. If I define a range to allow users to edit, they can change the text in the headings but it does not allow the dropdown lists to be used. If I unprotect the worksheet and then lock it again with "Allow all users of this workbook to:" and tick "Sort" and "Use AutoFilter", it works. I save and it works. Then, I close and open the file again and the ability is lost and the options have been unticked.

Can someone please tell me how I can stop these options being disabled?

 

[TheJay]

I believe the issue is code in ThisWorkbook:

Private Sub Workbook_Open()
Dim Sh          As Worksheet
    For Each Sh In Worksheets
        Sh.Protect UserInterFaceOnly:=True
    Next
End Sub

How do I add an exception to either allow sorting and autofilter to work on the sheet "VO Areas", allow sorting and autofilter on C171-E171 or is there another option that will work just as well or better?

Thanks for your help.

 

[Alex Blakenburg]

How about changing your Workbook_Open code to this:

Private Sub Workbook_Open()
    Dim Sh          As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = "VO Areas" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
        Else
            Sh.Protect UserInterFaceOnly:=True
        End If
    Next
End Sub

The sorting seems a bit tricky though. All the cells in the sort range need to be unlocked which seems an unlikely scenario.

 

[TheJay]

Thank you, that definitely unlocks the functionality. AWESOME!

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.

 

[TheJay]

Could you please tell me how I would define multiple sheets that it should be possible to autosort/filter on or if the list is long, have it work to define those that should not be autosorted/filtered?

 

[Alex Blakenburg]

Just convert the if statement to a Select Case.
See which is going to be less maintenance for you to ie whether you lists the ones you want to include or those you want to exclude.

    Dim Sh          As Worksheet
    
    For Each Sh In Worksheets
    
        Select Case Sh.Name
            Case "VO Areas", "Protect 2"
                Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Case Else
                Sh.Protect UserInterFaceOnly:=True
        End Select
        
    Next

 

[TheJay]

Thank you.

Now I have a problem with the other code that needs incorporating with the above. I have a search page and it produces a list of search results from all the other spreadsheets in the worksheet, along with a hyperlink in the left hand column of each result. I want everything protected from being copies/pasted except for the hyperlink in the first column. So, I formatting all cells except the first column and protected them, then the code locks the sheet.

Part of the reason for this is because one of the columns has an email address in it and clicking on it causes a debug error and it stops all macros working unless all workbooks are closed and reopened.

Option Explicit

Private mPrevSheet As Worksheet
'Reset the search page and show only these worksheets
Private Sub Workbook_Open()

    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With

    Dim sht As Worksheet

    With Worksheets("Search")
        .Pictures.Delete
        .Range("A1").Clear
        .Range("A3:H500").Clear
        With .Range("A3:A500")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
    
    Worksheets("Search").Activate
'    Worksheets("Contents").Activate
      
End Sub

I think I need this code to unlock the sheet, execute and then lock it after finishing?

The error comes at this point at the moment:

    With Worksheets("Search")

        .Pictures.Delete

        .Range("A1").Clear

        .Range("A3:H500").Clear

        With .Range("A3:A500")

            .HorizontalAlignment = xlCenter

            .VerticalAlignment = xlCenter

        End With

    End With

 

[TheJay]

Trying to incorporate the code you proposed brings up an error because the sheet is protected. When it's not protected, it comes up with VB Error 400. This is all code in ThisWorkbook.

Option Explicit

Private mPrevSheet As Worksheet
'Reset the search page and show only these worksheets
Private Sub Workbook_Open()

    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
  
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With

    Dim sht As Worksheet

    With Worksheets("Search")
        .Pictures.Delete
        .Range("A1").Clear
        .Range("A3:H500").Clear
        With .Range("A3:A500")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
  
    Worksheets("Search").Activate
'    Worksheets("Contents").Activate

    Dim Sh          As Worksheet
  
    For Each Sh In Worksheets
  
        Select Case Sh.Name
            Case "Cs", "LCs", "Ls", "HAs", "LSA", "Ss", "Es"
                Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Case Else
                Sh.Protect UserInterFaceOnly:=True
        End Select
      
    Next
      
End Sub

Code that operates the search sheet:

Option Explicit

Private Sub Worksheet_Activate()
    Range("A1").Select
    With Worksheets("Search")
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = True
        .DisplayVerticalScrollBar = True
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
    End With
    With Application
           .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End With
End Sub

Sub Set_Search()
Call Reset1
    Dim wks As Excel.Worksheet
    Dim rCell As Excel.Range
    Dim fFirst As String
    Dim n As Long
    Dim MyVal As String
    MyVal = InputBox("Enter the full name of an individual, department, organisation or area that you wish to contact.", "Contact Search", "")
    If MyVal = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Cells(1, 1)
        .Value = "Found '" & MyVal & "' in the following cells:" & vbCrLf & "(click below to view the original data)"
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With Selection.Font
             .Name = "Arial"
             .FontStyle = "Regular"
             .Size = 10
        End With
    End With
    n = 3
    Dim a, i As Long, ii As Long, rng As Range, x As Range, LastR As Range
    Set LastR = Cells(3, 2)
    For Each wks In ActiveWorkbook.Worksheets
         If (wks.Name <> "Search") And (wks.Name <> "Contents") And (wks.Name <> "Help") Then
            Set rng = Intersect(wks.Range("A:L"), wks.UsedRange)
            a = rng.Value
            If IsArray(a) Then
                For i = 1 To UBound(a, 1)
                    For ii = 1 To UBound(a, 2)
                        If UCase$(CStr(a(i, ii))) Like "*" & UCase$(MyVal) & "*" Then
                            rng.Cells(i, ii).Hyperlinks.Add Cells(n, 1), "", "'" & _
                                wks.Name & "'!" & rng.Cells(i, ii).Address
                            If x Is Nothing Then
                                Set x = wks.Rows(i).Range("a1:k1")
                            Else
                                Set x = Union(x, wks.Rows(i).Range("a1:k1"))
                            End If
                            n = n + 1: Exit For
                        End If
                    Next
                Next
                If Not x Is Nothing Then
                    x.Copy LastR: Set x = Nothing
                    Set LastR = Cells(Rows.Count, 1).End(xlUp)(2, 2)
                End If
            End If
         End If
    Next wks
    If n = 3 Then
        MsgBox "No results containing your search term were found." & vbCrLf & "" & vbCrLf & "Your search for '" & MyVal & "' did not match any exising data." & vbCrLf & "" & vbCrLf & "These contact details will be added.", 64, "Contact Search"
        Cells(1, 1).Value = ""
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim wsName As String
    Application.EnableEvents = False
    If InStr(1, Target.Parent, "!") Then
        wsName = Left$(Target.Parent, InStr(Target.Parent, "!") - 1)
        If wsName Like "*'" Then wsName = Left$(wsName, Len(wsName) - 1)
    Else
        wsName = Target.Parent.Name
    End If
    Sheets(wsName).Visible = -1
    Sheets(wsName).Activate
    Application.EnableEvents = True
End Sub

 

[TheJay]

Previously added code to stop errors showing when the email addresses are clicked (debut comes up and it stops the macros from working as described above), but I'd rather stop them being clicked in the first place or make them work without bringing up an error:

Also in ThisWorkbook:

'Stop errors from appearing when links clicked on particular worksheets
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)

    If Sh.Name = "Contents" Or Sh.Name = "Search" Then
        If Not mPrevSheet Is Nothing Then
            mPrevSheet.Visible = xlSheetHidden
        End If
        If Len(Target.Address) = 0 Then
            Set mPrevSheet = Range(Target.SubAddress).Parent
            If Not mPrevSheet Is Nothing Then
                mPrevSheet.Visible = xlSheetVisible
                Application.Goto mPrevSheet.Range(Target.SubAddress), False
            End If
        End If
    End If
    
End Sub