This is for a template with a name list that changes monthly. I pieced together <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">vba</acronym> codes that works as is but would like to
1.Simplify code with notes for changes. template button = Mega.megaform
2.Name list starting below A3.This is For existing name list create a message prompts to reverse first/last name before proceeding.
2(b). Separate option to insert individual names to an existing list without deleting the existing data. (insert name in alphabet order, create tab, copy of master sheet) use the +1 button
3. Each worksheet is saved in a Directory using naming scheme Master (folder) - Month (folder) - Team name (Wksheet)
A1 contains the team name. Create a drop down list that updates as new team wksheet as they added to the directory for that month.
4. Keep the Summary format (colors,fonts size etc.)
File https://app.box.com/s/f972jqlgbu3wl4osnmtkadg3efpmuv1a
<acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym> code:
Sub Megaform()
'Flip Names'
Dim Rng As Range
Dim WorkRng As Range
Dim Sign As String
On Error Resume Next
'If MsgBox("ALL DATA EXCEPT The List of Names Will Be DELETED Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
' The rest of your code goes here
'If MsgBox("ARE YOUR SURE Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
' The rest of your code goes here
'If MsgBox("DO NOT PROCEED WITHOUT A WITNESS PRESENT is there one present? Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
If MsgBox("IT IS OUT of Your Hands after this Are you sure? Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
'This Clears all the last cell with totals'
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Team Summary")
For x = 4 To ws.Range("A" & Rows.Count).End(xlUp).Row
If ws.Range("A" & x).Value = "Total by Week" Then
ws.Range("A" & x & ":" & "H" & x).Cells.ClearContents
End If
Next x
'Remove Commas Place in Aplha order'
Range("A4:A").Select
Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A4").Select
Range("A4:A").Sort _
Key1:=Range("A4"), Order1:=xlAscending
'Flips name by space
Range("A4:A").Select
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Sign = Application.InputBox("Symbol interval", xTitleId, " ", Type:=2)
For Each Rng In WorkRng
xValue = Rng.Value
NameList = <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym>.Split(xValue, Sign)
If UBound(NameList) = 1 Then
Rng.Value = NameList(1) + Sign + NameList(0)
End If
Next
'Order
Dim actSheet As Worksheet
Dim upper, lower As Integer
Dim tempString As String
Dim selectedArea As Range
Set actSheet = Application.Worksheets("Team Summary")
' here you have to put in your part to make the right selection
actSheet.Range("A4:A30").Select
Set selectedArea = Selection
upper = selectedArea.Row
lower = upper + selectedArea.Rows.Count - 1
tempString = "A4" & CStr(upper) & ":A" & CStr(lower)
actSheet.Sort.SortFields.Clear
actSheet.Sort.SortFields.Add Key:=Range(tempString), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With actSheet.Sort
.SetRange selectedArea
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Remove old tabs'
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Team Summary" And xWs.Name <> "Master" Then
xWs.Delete
End If
Next
'Link Names to New Tab'
Dim i As Integer
Dim wks As Worksheet
Dim Last_Row As Long
Application.ScreenUpdating = False
Set wks = Sheets("Team Summary")
Last_Row = wks.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To Last_Row
Sheets("Master").Copy Before:=Sheets(Sheets.Count)
ActiveSheet.Name = wks.Cells(i, 1)
ActiveSheet.Cells(2, 1) = wks.Cells(i, 1)
Next
Calculate
With Sheets("Team Summary")
For i = 4 To .Range("A" & .Rows.Count).End(xlUp).Row
.Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", _
SubAddress:="'" & .Range("A" & i).Value & "'!A4", TextToDisplay:=.Range("A" & i).Value
Next i
End With
Application.DisplayAlerts = False
Sheets("Team Summary").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = False
'Team Metrics Update'
Range("J4:J17").Value = "=SUM('*'!C4,'*'!C35,'*'!C66)"
Range("J19:J23").Value = "=SUM('*'!C20,'*'!C51,'*'!C82)"
Range("J24").Value = "=SUM('*'!C27,'*'!C58,'*'!C89)"
Application.DisplayAlerts = True
Application.ScreenUpdating = False
'
' ENDROW Adds Sums of colums by week Macro
'
Dim N As Long
'Sums up individual Colums adds up all cells at end of list
N = Cells(Rows.Count, "C").End(xlUp).Row
Cells(N + 1, "C").Formula = "=SUM(C4:C" & N & ")"
N = Cells(Rows.Count, "E").End(xlUp).Row
Cells(N + 1, "E").Formula = "=SUM(E4:E" & N & ")"
N = Cells(Rows.Count, "G").End(xlUp).Row
Cells(N + 1, "G").Formula = "=SUM(G4:G" & N & ")"
N = Cells(Rows.Count, "H").End(xlUp).Row
Cells(N + 1, "H").Formula = "=SUM(H4:H" & N & ")"
'Total text at end of list
N = Cells(Rows.Count, "B").End(xlUp).Row
Cells(N + 1, "B").Formula = "Week 1 Total"
N = Cells(Rows.Count, "D").End(xlUp).Row
Cells(N + 1, "D").Formula = "Week 2 Total"
N = Cells(Rows.Count, "F").End(xlUp).Row
Cells(N + 1, "F").Formula = "Week 3 Total"
N = Cells(Rows.Count, "A").End(xlUp).Row
Cells(N + 1, "A").Formula = "Total by Week"
Range("B2").Formula = "=VLOOKUP(9.99999999999999E+307,H:H,1)"
'N = Cells(Rows.Count, "B2").End(xlUp).Row
'Cells(N + 1, "B2").Formula = "=VLOOKUP(9.99999999999999E+307,H:H,1)"
'Center Text
N = Cells(Rows.Count, "A").End(xlUp).Row
Cells(N + 1, "H").Select
Range("A2").Select
End Sub
1.Simplify code with notes for changes. template button = Mega.megaform
2.Name list starting below A3.This is For existing name list create a message prompts to reverse first/last name before proceeding.
2(b). Separate option to insert individual names to an existing list without deleting the existing data. (insert name in alphabet order, create tab, copy of master sheet) use the +1 button
3. Each worksheet is saved in a Directory using naming scheme Master (folder) - Month (folder) - Team name (Wksheet)
A1 contains the team name. Create a drop down list that updates as new team wksheet as they added to the directory for that month.
4. Keep the Summary format (colors,fonts size etc.)
File https://app.box.com/s/f972jqlgbu3wl4osnmtkadg3efpmuv1a
<acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym> code:
Sub Megaform()
'Flip Names'
Dim Rng As Range
Dim WorkRng As Range
Dim Sign As String
On Error Resume Next
'If MsgBox("ALL DATA EXCEPT The List of Names Will Be DELETED Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
' The rest of your code goes here
'If MsgBox("ARE YOUR SURE Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
' The rest of your code goes here
'If MsgBox("DO NOT PROCEED WITHOUT A WITNESS PRESENT is there one present? Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
If MsgBox("IT IS OUT of Your Hands after this Are you sure? Select 'Yes' or 'No'", vbYesNo, "Selection") = vbNo Then Exit Sub
'This Clears all the last cell with totals'
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Team Summary")
For x = 4 To ws.Range("A" & Rows.Count).End(xlUp).Row
If ws.Range("A" & x).Value = "Total by Week" Then
ws.Range("A" & x & ":" & "H" & x).Cells.ClearContents
End If
Next x
'Remove Commas Place in Aplha order'
Range("A4:A").Select
Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A4").Select
Range("A4:A").Sort _
Key1:=Range("A4"), Order1:=xlAscending
'Flips name by space
Range("A4:A").Select
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Sign = Application.InputBox("Symbol interval", xTitleId, " ", Type:=2)
For Each Rng In WorkRng
xValue = Rng.Value
NameList = <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym>.Split(xValue, Sign)
If UBound(NameList) = 1 Then
Rng.Value = NameList(1) + Sign + NameList(0)
End If
Next
'Order
Dim actSheet As Worksheet
Dim upper, lower As Integer
Dim tempString As String
Dim selectedArea As Range
Set actSheet = Application.Worksheets("Team Summary")
' here you have to put in your part to make the right selection
actSheet.Range("A4:A30").Select
Set selectedArea = Selection
upper = selectedArea.Row
lower = upper + selectedArea.Rows.Count - 1
tempString = "A4" & CStr(upper) & ":A" & CStr(lower)
actSheet.Sort.SortFields.Clear
actSheet.Sort.SortFields.Add Key:=Range(tempString), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With actSheet.Sort
.SetRange selectedArea
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Remove old tabs'
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Team Summary" And xWs.Name <> "Master" Then
xWs.Delete
End If
Next
'Link Names to New Tab'
Dim i As Integer
Dim wks As Worksheet
Dim Last_Row As Long
Application.ScreenUpdating = False
Set wks = Sheets("Team Summary")
Last_Row = wks.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To Last_Row
Sheets("Master").Copy Before:=Sheets(Sheets.Count)
ActiveSheet.Name = wks.Cells(i, 1)
ActiveSheet.Cells(2, 1) = wks.Cells(i, 1)
Next
Calculate
With Sheets("Team Summary")
For i = 4 To .Range("A" & .Rows.Count).End(xlUp).Row
.Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", _
SubAddress:="'" & .Range("A" & i).Value & "'!A4", TextToDisplay:=.Range("A" & i).Value
Next i
End With
Application.DisplayAlerts = False
Sheets("Team Summary").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = False
'Team Metrics Update'
Range("J4:J17").Value = "=SUM('*'!C4,'*'!C35,'*'!C66)"
Range("J19:J23").Value = "=SUM('*'!C20,'*'!C51,'*'!C82)"
Range("J24").Value = "=SUM('*'!C27,'*'!C58,'*'!C89)"
Application.DisplayAlerts = True
Application.ScreenUpdating = False
'
' ENDROW Adds Sums of colums by week Macro
'
Dim N As Long
'Sums up individual Colums adds up all cells at end of list
N = Cells(Rows.Count, "C").End(xlUp).Row
Cells(N + 1, "C").Formula = "=SUM(C4:C" & N & ")"
N = Cells(Rows.Count, "E").End(xlUp).Row
Cells(N + 1, "E").Formula = "=SUM(E4:E" & N & ")"
N = Cells(Rows.Count, "G").End(xlUp).Row
Cells(N + 1, "G").Formula = "=SUM(G4:G" & N & ")"
N = Cells(Rows.Count, "H").End(xlUp).Row
Cells(N + 1, "H").Formula = "=SUM(H4:H" & N & ")"
'Total text at end of list
N = Cells(Rows.Count, "B").End(xlUp).Row
Cells(N + 1, "B").Formula = "Week 1 Total"
N = Cells(Rows.Count, "D").End(xlUp).Row
Cells(N + 1, "D").Formula = "Week 2 Total"
N = Cells(Rows.Count, "F").End(xlUp).Row
Cells(N + 1, "F").Formula = "Week 3 Total"
N = Cells(Rows.Count, "A").End(xlUp).Row
Cells(N + 1, "A").Formula = "Total by Week"
Range("B2").Formula = "=VLOOKUP(9.99999999999999E+307,H:H,1)"
'N = Cells(Rows.Count, "B2").End(xlUp).Row
'Cells(N + 1, "B2").Formula = "=VLOOKUP(9.99999999999999E+307,H:H,1)"
'Center Text
N = Cells(Rows.Count, "A").End(xlUp).Row
Cells(N + 1, "H").Select
Range("A2").Select
End Sub
