Macro prompts and user inputs

Hey Leith - Thanks again for the great coding work...

I implemented your code for jumping to patient profiles. I was also able to rework a bit of your code to create a "Remove Patient" UserForm. It uses the same code to load the sheets - but for CommandButton2_Click it uses .ListIndex as part of the Sheets ().delete command

Private Sub CommandButton2_Click()
 'Remove Patient 
   With ComboBox1
     If .ListIndex > -1 Then 
      ' Application.DisplayAlerts = False
       Sheets(.List(.ListIndex)).Delete
       Application.DisplayAlerts = True
     End If
   End With
   Unload Me
End Sub

I also added Unload Me to remove the UserForm after execution (and applied the concept to the other UserForms). I am now working on simply providing a list of worksheets on the directory sheet - More of an FYI for whomever is using the database. With the "New Patient", "Jump To Patient", and "Remove Patient" forms built - The database is pretty close to being done.

As always - I appreciate your advice and mentoring nature.

Originally Posted by Leith Ross

Hello aboveliquidice,

Good job on modifying the code to make a "Remove" button. I am glad I didn't include that piece. I had thought about it. What's is your plan for list on the worksheet?

I am still working on ideas - The concept of populating a table w/ data is pretty common - Lots of people use pivot tables to display thereafter - I am still learning the usage of said tables.

What would you use to display the data??? The Table will have 3 columns: Number, PatientName, Day of pickup (specific day of the week). I am just looking for some simple code to draw the data in and display it alphabetically. It would be nice to link the "Day of Pickup" to the specific cell on the respective patient data file - but it isn't really a necessity.

One question I do have concerns forcing the user to enable macros...

I located a great code made by a Ken Pulls that opens the workbook to a "Macro" page that discusses the need to enable Macros. It also codes to hide all other sheets until Macros is enabled. This seems prudent considering the users lack of experience with excel. The code is as follows:

Place the following code in the ThisWorkbook module of your workbook:
Option Explicit

Const WelcomePage = "Macros"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Ensure that the macro instruction sheet is saved as the only
'               visible worksheet in the workbook
    Dim ws As Worksheet
    Dim wsActive As Worksheet
    Dim vFilename As Variant
    Dim bSaved As Boolean

    'Turn off screen flashing
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Record active worksheet
    Set wsActive = ActiveSheet

    'Save workbook directly or prompt for saveas filename
    If SaveAsUI = True Then
        vFilename = Application.GetSaveAsFilename( _
                    fileFilter:="Excel Files (*.xls*), *.xls*")
        If CStr(vFilename) = "False" Then
            bSaved = False
        Else
            'Save the workbook using the supplied filename
            Call HideAllSheets
            ThisWorkbook.SaveAs vFilename
            Application.RecentFiles.Add vFilename
            Call ShowAllSheets
            bSaved = True
        End If
    Else
        'Save the workbook
        Call HideAllSheets
        ThisWorkbook.Save
        Call ShowAllSheets
        bSaved = True
    End If

    'Restore file to where user was
    wsActive.Activate

    'Restore screen updates
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    'Set application states appropriately
    If bSaved Then
        ThisWorkbook.Saved = True
        Cancel = True
    Else
        Cancel = True
    End If

End Sub

Private Sub Workbook_Open()
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Unhide all worksheets since macros are enabled
    Application.ScreenUpdating = False
    Call ShowAllSheets
    Application.ScreenUpdating = True
    ThisWorkbook.Saved = True
End Sub

Private Sub HideAllSheets()
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Hide all worksheets except the macro welcome page

    Dim ws As Worksheet

    Worksheets(WelcomePage).Visible = xlSheetVisible

    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
    Next ws

    Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Show all worksheets except the macro welcome page

    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
    Next ws

    Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub

Is there any way better than a redirect? I was thinking of having a popup box from a user form that has an autorun when a sheet is opened - Thoughts?

Okay - I am at a loss - I can build a tag on each patient file sheet to be designated as a table (really two data entries, one for name and one for date of pickup)... Then use the summarize with pivot table to build a new sheet with a table showing the patient's name and the day they pickup their medications.

However, I cannot replicate this for all of my patients - I can only summarize the data from one table on one sheet...

I have a feeling I am going about this wrong. Does anyone have a better solution?

Any and all help would be greatly appreciated.

I found some great code for a Table of Contents with Hyperlinks...

However, I am having trouble adapting it to my purposes.

Written by Dmc Ritchie and Bill Manville

Sub BuildTOC()
  'listed from active cell down 7-cols --  DMcRitchie 1999-08-14 2000-09-05
  Dim iSheet As Long, iBefore As Long
  Dim sSheetName As String, sActiveCell As String
  Dim cRow As Long, cCol As Long, cSht As Long
  Dim lastcell
  Dim qSht As String
  Dim mg As String
  Dim rg As Range
  Dim CRLF As String
  Dim Reply As Variant
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  cRow = ActiveCell.Row
  cCol = ActiveCell.Column
  sSheetName = UCase(ActiveSheet.Name)
  sActiveCell = UCase(ActiveCell.Value)
  mg = ""
  CRLF = Chr(10)  'Actually just CR
  Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
  rg.Select
  If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
  If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
  If mg <> "" Then
     mg = "Warning BuildTOC will destructively rewrite the selected area" _
     & CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
      & "the affected area will be rewritten, or" & CRLF & _
      "Press CANCEL to check area then reinvoke this macro (BuildTOC)"
     Application.ScreenUpdating = True  'make range visible
     Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
      & " items in workbook" & Chr(10) & "revised will now occupy up to 10 columns")
     Application.ScreenUpdating = False
     If Reply <> 1 Then GoTo AbortCode
  End If
  rg.Clear      'Clear out any previous hyperlinks, fonts, etc in the area
  For cSht = 1 To ActiveWorkbook.Sheets.Count
     Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
     If TypeName(Sheets(cSht)) = "Worksheet" Then
        'hypName = "'" & Sheets(csht).Name
        ' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace not in XL97
        qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
        If CDbl(Application.Version) <  8.0  Then
          '-- use next line for XL95
          Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name  'XL95
        Else
          '-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
          Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).CodeName

          '--- excel is not handling lots of objects well ---
          'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _
          '  Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
          '--- so will use the HYPERLINK formula instead ---
          '--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
          ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
            "=hyperlink(""[" & ActiveWorkbook.Name _
            & "]'" & qSht & "'!A1"",""" & qSht & """)"
        End If
     Else
       Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
     End If
     Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
    ' -- activate next line to include content of cell A1 for each sheet
    ' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
     On Error Resume Next
     Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
     If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
     Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
     Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
     On Error GoTo 0
  Next cSht

  'Now sort the results:  2. Type(D), 1. Name (A), 3. module(unsorted)
  rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
      , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
  rg.Columns.AutoFit
  rg.Select           'optional
  'if cells above range are blank want these headers
  ' Worksheet,   Type,    codename
  If cRow > 1 Then
     If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
        Cells(cRow - 1, cCol) = "Worksheet"
        Cells(cRow - 1, cCol + 1) = "Type"
        Cells(cRow - 1, cCol + 2) = "CodeName"
        Cells(cRow - 1, cCol + 3) = "[opt.]"
        Cells(cRow - 1, cCol + 4) = "Lastcell"
        Cells(cRow - 1, cCol + 5) = "cells"
        Cells(cRow - 1, cCol + 6) = "ScrollArea"
        Cells(cRow - 1, cCol + 7) = "PrintArea"
     End If
  End If
  Application.ScreenUpdating = True
  Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
     "Would you like the tabs in workbook also sorted", _
     vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
     & " tabs in workbook")
  Application.ScreenUpdating = False
  If Reply = 1 Then SortALLSheets  'Invoke macro to Sort Sheet Tabs
  Sheets(sSheetName).Activate
AbortCode:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
   Cells(3, 1).Select
   BuildTOC
End Sub

The code above produces a good product - but It has way too many columns and language for various versions of excel (which I do not need)...

Thoughts?