Use with Excel file: 9.5.22 here
Submit button runs these modules below:
Private Sub CommandButton1_Click()
ssnTo4
changetoshortdatesSub
runColumnOnly
arrayCreateTabsFilterGI
deleteSomeSpecificSheets
SortWorksheetsTabs
hyperlinkTOC
End Sub
Option Explicit
Sub ssnTo4()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("Master")
Dim lastRow As Long
lastRow = shData.Range("B" & Rows.Count).End(xlUp).row
shData.Activate
shData.Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
shData.Range("C5").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],4)"
shData.Range("C5").Select
Selection.AutoFill Destination:=shData.Range("C5:C" & lastRow)
shData.Columns("C:C").Select
Selection.Copy
shData.Columns("D:D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
shData.Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "AccessLevel"
shData.Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
shData.Range("B1").Select
End Sub
Sub changetoshortdatesSub()
Range("C:C,D:D,E:E,J:J").Select
Range("J1").Activate
Selection.NumberFormat = "m/d/yyyy"
Range("B1").Select
End Sub
Option Explicit
Sub runColumnOnly()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Master")
With ws.Range("I:I")
.Cells.Replace "~/", ""
.Cells.Replace "~*", ""
End With
'ActiveSheet.Cells.Replace "~/", ""
'ActiveSheet.Cells.Replace "~*", ""
End Sub
Option Explicit
Sub arrayCreateTabsFilterGI()
Dim a As Long
Dim marks As String
Dim tally As Long
Dim numRows As Long
Dim lastRow0 As Long
Dim n, i As Integer
Dim myarray(), array2()
myarray = Array("BLUE 1", "BLUE 2", "BLUE 5", "BLUE 6", "EVANSTON 2 WH CBOC", "GOLD 1", "GOLD 2", "GOLD 3", "GOLD 4", "GOLD 5", "GREEN 1", "GREEN 3", "GREEN 4", "GREEN 5", "GREEN 6", "HBPC 1 HBPC", "HBPC 2 HBPC", "KENOSHA 1 WH CBOC", "KENOSHA 2 WH CBOC", "MC HENRY 1 WH CBOC", "MC HENRY 2 CBOC", "MC HENRY 4 WH CBOC", "MC HENRY 5 CBOC", "Norm New", "SPINAL CORD INJURY SCI", "WOMENS HEALTH 1 WH CLINIC", "WOMENS HEALTH 2 WH CLINIC")
'don't forget to remove forward slashes from any array elements
For i = LBound(myarray) To UBound(myarray)
'Next i
Dim shData As Worksheet, shOutput As Worksheet
Worksheets.Add.Name = myarray(i)
Set shData = ThisWorkbook.Worksheets("Master")
Set shOutput = ThisWorkbook.Worksheets(myarray(i))
shOutput.Rows(1).Value = shData.Rows(4).Value
shOutput.Columns("A:L").AutoFit
shOutput.Range("A1").CurrentRegion.Offset(1).Clear 'this clears BOTH content & formatting
'Get the range of "Sheet1" worksheet
shData.Activate
Dim rg As Range
Set rg = shData.Range("A4").CurrentRegion 'this places you in A4 in 'Master' tab & selects area with contiguous data
'The main code
Dim j, row As Long
row = 2 'important! you'll now start in 2nd row within the area that was selected as "CurrentRegion" . . .
For j = 2 To rg.Rows.Count
marks = rg.Cells(j, 9).Value
If marks = myarray(i) Then
'Copy using selections
shOutput.Range("A" & row).Resize(1, rg.Columns.Count).Value = rg.Rows(j).Value
'move to the next output row
row = row + 1
Worksheets(myarray(i)).Activate
With ActiveSheet
numRows = .Cells(.Rows.Count, "B").End(xlUp).row
.Range("Q1").Value = numRows - 1
tally = .Range("Q1").Value
Range("A2", Range("L2").End(xlDown)).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlNo 'sort by column H2--after looking across from A2 to L2
End With
End If
Next j 'we have to finish the "For j" loop 1st to get a final total for each clinic BEFORE moving to the code below . . .
'Worksheets(myarray(i)).Activate
'
'With ActiveSheet
' numRows = .Cells(.Rows.Count, "B").End(xlUp).row
' .Range("E1").Value = numRows - 1
' tally = .Range("E1").Value
' Range("A2", Range("C2").End(xlDown)).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo 'sort by column A2--after looking across from A2 to C2
'
'
' array2 = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
' "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS")
'
' Worksheets("Tally").Activate
'
' lastRow0 = Worksheets("Tally").Range(array2(i) & Rows.Count).End(xlUp).row + 1
' 'MsgBox "array2(i) is: " & array2(i)
' 'MsgBox "Lastrow0 is: " & lastRow0
' Range(array2(i) & lastRow0).Value = tally
' End With
Next i
End Sub
Sub deleteSomeSpecificSheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name = "instrxns" Or ws.Name = "Submit" Or ws.Name = "Norm New" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub SortWorksheetsTabs()
Application.ScreenUpdating = False
Dim ShCount As Integer, i As Integer, j As Integer
ShCount = Sheets.Count
For i = 1 To ShCount - 1
For j = i + 1 To ShCount
If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub hyperlinkTOC()
Dim i As Integer
Sheets.Add(before:=Sheets(1)).Name = "Table of Contents"
Worksheets("Table of Contents").Range("A1").Value = "Click on any of the below links to view that clinical area"
'Sheets.Add Before:=Sheets(1)
For i = 2 To Worksheets.Count
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(i, 1), _
Address:="", _
SubAddress:="'" & Worksheets(i).Name & "'!A1", _
TextToDisplay:=Worksheets(i).Name
Next i
Worksheets("Table of Contents").Columns("A:A").AutoFit
End Sub