API tools faq
paste
Advertisement
illpastethat

New participant sort excel

illpastethat
Nov 19th, 2015
436
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VB.NET 14.72 KB | None | 0 0
raw download clone embed print report
  1. 'Enable Microsoft scripting library first via Tools > References > Microsoft Scripting Library/Runtime
  2. Public Function CountUnique(rng As Range) As Integer
  3.     Dim dict As Dictionary
  4.     Dim cell As Range
  5.     Set dict = New Dictionary
  6.     For Each cell In rng.Cells
  7.          If Not dict.Exists(cell.Value) Then
  8.             dict.Add cell.Value, 0
  9.         End If
  10.     Next
  11.     CountUnique = dict.Count
  12. End Function
  13. Sub ParticipantSort()
  14. 'Sorts participants by fundraising level and provides segmented results.
  15.     Dim SheetName As String, number As Double
  16.     Application.ScreenUpdating = False
  17.     number = Application.CountA(Columns(1))
  18.     SheetName = Format(Date, "mmm-dd-yyyy") & " Participant Report"
  19.     Worksheets(1).Name = SheetName
  20.     Sheets.Add After:=ActiveSheet
  21.     Sheets("Sheet1").Select
  22.     Sheets("Sheet1").Name = "Segmented Results"
  23.     ActiveCell.FormulaR1C1 = "Segmented Results"
  24.     Range("A1:C1").Select
  25.     Application.WindowState = xlNormal
  26.     With Selection.Font
  27.         .Name = "Calibri"
  28.         .Size = 20
  29.         .Strikethrough = False
  30.         .Superscript = False
  31.         .Subscript = False
  32.         .OutlineFont = False
  33.         .Shadow = False
  34.         .Underline = xlUnderlineStyleNone
  35.         .ThemeColor = xlThemeColorLight1
  36.         .TintAndShade = 0
  37.         .ThemeFont = xlThemeFontMinor
  38.     End With
  39.     Selection.Font.Bold = True
  40.     With Selection
  41.         .HorizontalAlignment = xlCenter
  42.         .VerticalAlignment = xlBottom
  43.         .WrapText = False
  44.         .Orientation = 0
  45.         .AddIndent = False
  46.         .IndentLevel = 0
  47.         .ShrinkToFit = False
  48.         .ReadingOrder = xlContext
  49.         .MergeCells = False
  50.     End With
  51.     Selection.Merge
  52.     Range("A2").Select
  53.     ActiveCell.FormulaR1C1 = "Group"
  54.     Range("B2").Select
  55.     ActiveCell.FormulaR1C1 = "# of Participants"
  56.     Range("C2").Select
  57.     ActiveCell.FormulaR1C1 = "$ Raised"
  58.     Range("A3").Select
  59.     ActiveCell.FormulaR1C1 = "$0 - $10"
  60.     Range("A4").Select
  61.     ActiveCell.FormulaR1C1 = "$10.01 - $50"
  62.     Range("A5").Select
  63.     ActiveCell.FormulaR1C1 = "$50.01 - $100"
  64.     Range("A6").Select
  65.     ActiveCell.FormulaR1C1 = "$100.01 - $200"
  66.     Range("A7").Select
  67.     ActiveCell.FormulaR1C1 = "$200.01 - $500"
  68.     Range("A8").Select
  69.     ActiveCell.FormulaR1C1 = "$500.01 - $1,000"
  70.     Range("A9").Select
  71.     ActiveCell.FormulaR1C1 = "$1,000.01 - $20,000"
  72.     Columns("A:A").EntireColumn.AutoFit
  73.     Range("A2:C2").Select
  74.     Selection.Font.Bold = True
  75.     With Selection.Font
  76.         .Name = "Calibri"
  77.         .Size = 13
  78.         .Strikethrough = False
  79.         .Superscript = False
  80.         .Subscript = False
  81.         .OutlineFont = False
  82.         .Shadow = False
  83.         .Underline = xlUnderlineStyleNone
  84.         .ThemeColor = xlThemeColorLight1
  85.         .TintAndShade = 0
  86.         .ThemeFont = xlThemeFontMinor
  87.     End With
  88.     Columns("B:B").EntireColumn.AutoFit
  89.     Columns("C:C").EntireColumn.AutoFit
  90.     Range("C3:C9").Select
  91.     Selection.Style = "Currency"
  92.     Range("A2:C9").Select
  93.     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  94.     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  95.     With Selection.Borders(xlEdgeLeft)
  96.         .LineStyle = xlContinuous
  97.         .ColorIndex = 0
  98.         .TintAndShade = 0
  99.         .Weight = xlThin
  100.     End With
  101.     With Selection.Borders(xlEdgeTop)
  102.         .LineStyle = xlContinuous
  103.         .ColorIndex = 0
  104.         .TintAndShade = 0
  105.         .Weight = xlThin
  106.     End With
  107.     With Selection.Borders(xlEdgeBottom)
  108.         .LineStyle = xlContinuous
  109.         .ColorIndex = 0
  110.         .TintAndShade = 0
  111.         .Weight = xlThin
  112.     End With
  113.     With Selection.Borders(xlEdgeRight)
  114.         .LineStyle = xlContinuous
  115.         .ColorIndex = 0
  116.         .TintAndShade = 0
  117.         .Weight = xlThin
  118.     End With
  119.     With Selection.Borders(xlInsideVertical)
  120.         .LineStyle = xlContinuous
  121.         .ColorIndex = 0
  122.         .TintAndShade = 0
  123.         .Weight = xlThin
  124.     End With
  125.     With Selection.Borders(xlInsideHorizontal)
  126.         .LineStyle = xlContinuous
  127.         .ColorIndex = 0
  128.         .TintAndShade = 0
  129.         .Weight = xlThin
  130.     End With
  131.     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  132.     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  133.     With Selection.Borders(xlEdgeLeft)
  134.         .LineStyle = xlContinuous
  135.         .ColorIndex = 0
  136.         .TintAndShade = 0
  137.         .Weight = xlMedium
  138.     End With
  139.     With Selection.Borders(xlEdgeTop)
  140.         .LineStyle = xlContinuous
  141.         .ColorIndex = 0
  142.         .TintAndShade = 0
  143.         .Weight = xlMedium
  144.     End With
  145.     With Selection.Borders(xlEdgeBottom)
  146.         .LineStyle = xlContinuous
  147.         .ColorIndex = 0
  148.         .TintAndShade = 0
  149.         .Weight = xlMedium
  150.     End With
  151.     With Selection.Borders(xlEdgeRight)
  152.         .LineStyle = xlContinuous
  153.         .ColorIndex = 0
  154.         .TintAndShade = 0
  155.         .Weight = xlMedium
  156.     End With
  157.     With Selection.Borders(xlInsideVertical)
  158.         .LineStyle = xlContinuous
  159.         .ColorIndex = 0
  160.         .TintAndShade = 0
  161.         .Weight = xlThin
  162.     End With
  163.     With Selection.Borders(xlInsideHorizontal)
  164.         .LineStyle = xlContinuous
  165.         .ColorIndex = 0
  166.         .TintAndShade = 0
  167.         .Weight = xlThin
  168.     End With
  169.     Range("B3").Select
  170.     Worksheets(1).Select
  171.     Columns("A:B").Select
  172.     Selection.Delete Shift:=xlToLeft
  173.     Columns("B:C").Select
  174.     Selection.Delete Shift:=xlToLeft
  175.     Range("E1").Select
  176.     ActiveCell.FormulaR1C1 = "Captain"
  177.     Range("A1").Select
  178.     ActiveCell.FormulaR1C1 = "Reg. Date"
  179.     Range("A2").Select
  180.     Columns("A:A").EntireColumn.AutoFit
  181.     Columns("O:O").Select
  182.     Selection.Delete Shift:=xlToLeft
  183.     Columns("P:U").Select
  184.     Selection.Delete Shift:=xlToLeft
  185.     Range("P1").Select
  186.     ActiveCell.FormulaR1C1 = "Survivor"
  187.     Range("Q1").Select
  188.     ActiveCell.FormulaR1C1 = "Caregiver"
  189.     Columns("R:R").Select
  190.     Selection.Delete Shift:=xlToLeft
  191.     Selection.Delete Shift:=xlToLeft
  192.     Range("R1").Select
  193.     ActiveCell.FormulaR1C1 = "T-Shirt"
  194.     Columns("S:S").Select
  195.     Selection.Delete Shift:=xlToLeft
  196.     Range("S1").Select
  197.     ActiveCell.FormulaR1C1 = "Emails"
  198.     Columns("T:U").Select
  199.     Selection.Delete Shift:=xlToLeft
  200.     Range("T1").Select
  201.     ActiveCell.FormulaR1C1 = "Goal"
  202.     Range("U1").Select
  203.     ActiveCell.FormulaR1C1 = "$ given at registration"
  204.     Range("V1").Select
  205.     ActiveCell.FormulaR1C1 = "Returning?"
  206.     Range("W1").Select
  207.     Columns("W:X").Select
  208.     Selection.Delete Shift:=xlToLeft
  209.     Range("U9").Select
  210.     Columns("B:C").Select
  211.     Selection.Delete Shift:=xlToLeft
  212.     Columns("A:A").Select
  213.     Selection.Cut
  214.     Columns("F:F").Select
  215.     Selection.Insert Shift:=xlToRight
  216.     Columns("B:B").Select
  217.     Selection.Cut
  218.     Columns("F:F").Select
  219.     Selection.Insert Shift:=xlToRight
  220.     Columns("F:F").Select
  221.     Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  222.     Range("F1").Select
  223.     ActiveCell.FormulaR1C1 = "$ Raised (Include Reg.)"
  224.     Range("F2").Select
  225.     ActiveCell.FormulaR1C1 = "=SUM(RC[3]:RC[5])"
  226.     Range("F2").Select
  227.     Selection.AutoFill Destination:=Range("F2", Range("F" & number))
  228.     Range("F1", Range("F" & number)).Select
  229.     Columns("F:F").Select
  230.     Selection.Copy
  231.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  232.         :=False, Transpose:=False
  233.     Range("G3").Select
  234.     Application.CutCopyMode = False
  235.     Columns("G:K").Select
  236.     Selection.Delete Shift:=xlToLeft
  237.     Range("G1").Select
  238.     ActiveCell.FormulaR1C1 = "Promo"
  239.     Range("G2").Select
  240.     Columns("N:N").Select
  241.     Selection.Cut
  242.     Columns("G:G").Select
  243.     Selection.Insert Shift:=xlToRight
  244.     Columns("N:N").Select
  245.     Selection.Cut
  246.     Columns("H:H").Select
  247.     Selection.Insert Shift:=xlToRight
  248.     Columns("K:K").Select
  249.     Selection.Cut
  250.     Columns("I:I").Select
  251.     Selection.Insert Shift:=xlToRight
  252.     Columns("K:K").EntireColumn.AutoFit
  253.     Range("P3").Select
  254.     Columns("A:A").ColumnWidth = 25.57
  255.     Columns("B:B").ColumnWidth = 11.29
  256.     Columns("C:C").ColumnWidth = 14.29
  257.     Columns("E:E").EntireColumn.AutoFit
  258.     Columns("F:F").EntireColumn.AutoFit
  259.     Columns("G:G").EntireColumn.AutoFit
  260.     Columns("H:H").EntireColumn.AutoFit
  261.     Columns("I:I").EntireColumn.AutoFit
  262.     Columns("I:I").ColumnWidth = 23.57
  263.     Columns("J:J").EntireColumn.AutoFit
  264.     Columns("P:P").Select
  265.     Selection.Cut
  266.     Columns("J:J").Select
  267.     Selection.Insert Shift:=xlToRight
  268.     Range("M2").Select
  269.    
  270.    
  271.    
  272.     Columns("A:P").Select
  273.     Selection.AutoFilter
  274.     Range("F2").Select
  275.     Columns("F:F").EntireColumn.AutoFit
  276.     ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields. _
  277.         Add Key:=Range("F1", Range("F" & number)), SortOn:=xlSortOnValues, Order:=xlDescending, _
  278.         DataOption:=xlSortTextAsNumbers
  279.     With ActiveWorkbook.Worksheets(1).AutoFilter.Sort
  280.         .Header = xlYes
  281.         .MatchCase = False
  282.         .Orientation = xlTopToBottom
  283.         .SortMethod = xlPinYin
  284.         .Apply
  285.     End With
  286.     Columns("F:F").Select
  287.     Selection.FormatConditions.AddColorScale ColorScaleType:=3
  288.     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
  289.     Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
  290.         xlConditionValueLowestValue
  291.     With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
  292.         .Color = 7039480
  293.         .TintAndShade = 0
  294.     End With
  295.     Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
  296.         xlConditionValuePercentile
  297.     Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
  298.     With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
  299.         .Color = 8711167
  300.         .TintAndShade = 0
  301.     End With
  302.     Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
  303.         xlConditionValueHighestValue
  304.     With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
  305.         .Color = 8109667
  306.         .TintAndShade = 0
  307.     End With
  308.     Range("G3").Select
  309.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:="<=10", _
  310.         Operator:=xlAnd
  311.     Range("Q1").Select
  312.     ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,C[-11])"
  313.     Range("R1").Select
  314.     ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-12])"
  315.     Range("Q1:R1").Select
  316.     Selection.Copy
  317.     Sheets("Segmented Results").Select
  318.     Range("B3:C3").Select
  319.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  320.         :=False, Transpose:=False
  321.     Columns("C:C").ColumnWidth = 12
  322.     Range("B4").Select
  323.     Worksheets(1).Select
  324.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6
  325.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:=">=10.01" _
  326.         , Operator:=xlAnd, Criteria2:="<=50"
  327.     Application.CutCopyMode = False
  328.     Selection.Copy
  329.     Sheets("Segmented Results").Select
  330.     Range("B4:C4").Select
  331.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  332.         :=False, Transpose:=False
  333.     Range("B5:C5").Select
  334.     Worksheets(1).Activate
  335.     Worksheets(1).Select
  336.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6
  337.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:=">=50.01" _
  338.         , Operator:=xlAnd, Criteria2:="<=100"
  339.     Application.CutCopyMode = False
  340.     Selection.Copy
  341.     Sheets("Segmented Results").Select
  342.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  343.         :=False, Transpose:=False
  344.     Worksheets(1).Select
  345.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:= _
  346.         ">=100.01", Operator:=xlAnd, Criteria2:="<=200"
  347.     Application.CutCopyMode = False
  348.     Selection.Copy
  349.     Sheets("Segmented Results").Select
  350.     Range("B6:C6").Select
  351.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  352.         :=False, Transpose:=False
  353.     Worksheets(1).Select
  354.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:= _
  355.         ">=200.01", Operator:=xlAnd, Criteria2:="<=500"
  356.     Application.CutCopyMode = False
  357.     Selection.Copy
  358.     Sheets("Segmented Results").Select
  359.     Range("B7:C7").Select
  360.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  361.         :=False, Transpose:=False
  362.     Worksheets(1).Select
  363.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:= _
  364.         ">=500.01", Operator:=xlAnd, Criteria2:="<=1000"
  365.     Application.CutCopyMode = False
  366.     Selection.Copy
  367.     Sheets("Segmented Results").Select
  368.     Range("B8:C8").Select
  369.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  370.         :=False, Transpose:=False
  371.     Worksheets(1).Select
  372.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6, Criteria1:= _
  373.         ">=1000.01", Operator:=xlAnd, Criteria2:="<=20000"
  374.     Application.CutCopyMode = False
  375.     Selection.Copy
  376.     Sheets("Segmented Results").Select
  377.     Range("B9:C9").Select
  378.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  379.         :=False, Transpose:=False
  380.     Worksheets(1).Activate
  381.     ActiveSheet.Range("$A$1", Range("P" & number)).AutoFilter Field:=6
  382.     Application.CutCopyMode = False
  383.     Selection.ClearContents
  384.     ActiveWindow.SmallScroll ToRight:=-4
  385.     Range("A1").Select
  386.     Sheets("Segmented Results").Activate
  387.     Range("B10").Select
  388.     ActiveCell.FormulaR1C1 = "=SUM(R[-7]C:R[-1]C)"
  389.     Selection.AutoFill Destination:=Range("B10:C10"), Type:=xlFillDefault
  390.     Range("C10").Select
  391.     Selection.Style = "Currency"
  392.     Range("B3:B10").Select
  393.     Selection.NumberFormat = "#,##0"
  394.     Range("B10:C10").Select
  395.     Selection.Font.Bold = True
  396.     Range("A12").Select
  397.     ActiveCell.FormulaR1C1 = "% Non-Fundraisers:"
  398.     Range("A13").Select
  399.     ActiveCell.FormulaR1C1 = "Survivors:"
  400.     Range("A14").Select
  401.     ActiveCell.FormulaR1C1 = "Caregivers:"
  402.     Range("B12").Select
  403.     ActiveCell.FormulaR1C1 = "=R[-9]C/R[-2]C"
  404.     Range("B12").Select
  405.     Selection.Style = "Percent"
  406.     Range("B13").Select
  407.     ActiveCell.FormulaR1C1 = "=COUNTA('" & SheetName & "'!C[11]) - 1"
  408.     Range("B14").Select
  409.     ActiveCell.FormulaR1C1 = "=COUNTA('" & SheetName & "'!C[12]) - 1"
  410.     Range("B12").Select
  411.     Range("A15").Select
  412.     ActiveCell.FormulaR1C1 = "Teams:"
  413.     Range("B15").Select
  414.     ActiveCell.FormulaR1C1 = "=COUNTUNIQUE('" & SheetName & "'!C[-1]) -2"
  415.     Range("A1").Select
  416.     Application.ScreenUpdating = True
  417.     ActiveWorkbook.SaveAs Filename:="C:\Users\" & Environ$("Username") & "\Desktop\Dropbox\Relay 2016\Report Archive\" & SheetName, _
  418.         FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  419.     ActiveWindow.WindowState = xlMaximized
  420. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!