API tools faq
paste
Advertisement
illpastethat

excel participant sort

illpastethat
Mar 5th, 2015
480
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VB.NET 12.68 KB | None | 0 0
raw download clone embed print report
  1. Sub ParticipantSort()
  2. ' Sorts participants by fundraising level and provides segmented results.
  3.     Dim SheetName As String, number As Double
  4.     Application.ScreenUpdating = False
  5.     number = Application.WorksheetFunction.Count(Range("I:I"))
  6.     SheetName = Format(Date, "mmm-dd-yyyy") & " Participant Report"
  7.     Worksheets(1).Name = SheetName
  8.     Sheets.Add After:=ActiveSheet
  9.     Sheets("Sheet1").Select
  10.     Sheets("Sheet1").Name = "Segmented Results"
  11.     ActiveCell.FormulaR1C1 = "Segmented Results"
  12.     Range("A1:C1").Select
  13.     Application.WindowState = xlNormal
  14.     With Selection.Font
  15.         .Name = "Calibri"
  16.         .Size = 20
  17.         .Strikethrough = False
  18.         .Superscript = False
  19.         .Subscript = False
  20.         .OutlineFont = False
  21.         .Shadow = False
  22.         .Underline = xlUnderlineStyleNone
  23.         .ThemeColor = xlThemeColorLight1
  24.         .TintAndShade = 0
  25.         .ThemeFont = xlThemeFontMinor
  26.     End With
  27.     Selection.Font.Bold = True
  28.     With Selection
  29.         .HorizontalAlignment = xlCenter
  30.         .VerticalAlignment = xlBottom
  31.         .WrapText = False
  32.         .Orientation = 0
  33.         .AddIndent = False
  34.         .IndentLevel = 0
  35.         .ShrinkToFit = False
  36.         .ReadingOrder = xlContext
  37.         .MergeCells = False
  38.     End With
  39.     Selection.Merge
  40.     Range("A2").Select
  41.     ActiveCell.FormulaR1C1 = "Group"
  42.     Range("B2").Select
  43.     ActiveCell.FormulaR1C1 = "# of Participants"
  44.     Range("C2").Select
  45.     ActiveCell.FormulaR1C1 = "$ Raised"
  46.     Range("A3").Select
  47.     ActiveCell.FormulaR1C1 = "$0 - $10"
  48.     Range("A4").Select
  49.     ActiveCell.FormulaR1C1 = "$10.01 - $50"
  50.     Range("A5").Select
  51.     ActiveCell.FormulaR1C1 = "$50.01 - $100"
  52.     Range("A6").Select
  53.     ActiveCell.FormulaR1C1 = "$100.01 - $200"
  54.     Range("A7").Select
  55.     ActiveCell.FormulaR1C1 = "$200.01 - $500"
  56.     Range("A8").Select
  57.     ActiveCell.FormulaR1C1 = "$500.01 - $1,000"
  58.     Range("A9").Select
  59.     ActiveCell.FormulaR1C1 = "$1,000.01 - $20,000"
  60.     Columns("A:A").EntireColumn.AutoFit
  61.     Range("A2:C2").Select
  62.     Selection.Font.Bold = True
  63.     With Selection.Font
  64.         .Name = "Calibri"
  65.         .Size = 13
  66.         .Strikethrough = False
  67.         .Superscript = False
  68.         .Subscript = False
  69.         .OutlineFont = False
  70.         .Shadow = False
  71.         .Underline = xlUnderlineStyleNone
  72.         .ThemeColor = xlThemeColorLight1
  73.         .TintAndShade = 0
  74.         .ThemeFont = xlThemeFontMinor
  75.     End With
  76.     Columns("B:B").EntireColumn.AutoFit
  77.     Columns("C:C").EntireColumn.AutoFit
  78.     Range("C3:C9").Select
  79.     Selection.Style = "Currency"
  80.     Range("A2:C9").Select
  81.     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  82.     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  83.     With Selection.Borders(xlEdgeLeft)
  84.         .LineStyle = xlContinuous
  85.         .ColorIndex = 0
  86.         .TintAndShade = 0
  87.         .Weight = xlThin
  88.     End With
  89.     With Selection.Borders(xlEdgeTop)
  90.         .LineStyle = xlContinuous
  91.         .ColorIndex = 0
  92.         .TintAndShade = 0
  93.         .Weight = xlThin
  94.     End With
  95.     With Selection.Borders(xlEdgeBottom)
  96.         .LineStyle = xlContinuous
  97.         .ColorIndex = 0
  98.         .TintAndShade = 0
  99.         .Weight = xlThin
  100.     End With
  101.     With Selection.Borders(xlEdgeRight)
  102.         .LineStyle = xlContinuous
  103.         .ColorIndex = 0
  104.         .TintAndShade = 0
  105.         .Weight = xlThin
  106.     End With
  107.     With Selection.Borders(xlInsideVertical)
  108.         .LineStyle = xlContinuous
  109.         .ColorIndex = 0
  110.         .TintAndShade = 0
  111.         .Weight = xlThin
  112.     End With
  113.     With Selection.Borders(xlInsideHorizontal)
  114.         .LineStyle = xlContinuous
  115.         .ColorIndex = 0
  116.         .TintAndShade = 0
  117.         .Weight = xlThin
  118.     End With
  119.     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  120.     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  121.     With Selection.Borders(xlEdgeLeft)
  122.         .LineStyle = xlContinuous
  123.         .ColorIndex = 0
  124.         .TintAndShade = 0
  125.         .Weight = xlMedium
  126.     End With
  127.     With Selection.Borders(xlEdgeTop)
  128.         .LineStyle = xlContinuous
  129.         .ColorIndex = 0
  130.         .TintAndShade = 0
  131.         .Weight = xlMedium
  132.     End With
  133.     With Selection.Borders(xlEdgeBottom)
  134.         .LineStyle = xlContinuous
  135.         .ColorIndex = 0
  136.         .TintAndShade = 0
  137.         .Weight = xlMedium
  138.     End With
  139.     With Selection.Borders(xlEdgeRight)
  140.         .LineStyle = xlContinuous
  141.         .ColorIndex = 0
  142.         .TintAndShade = 0
  143.         .Weight = xlMedium
  144.     End With
  145.     With Selection.Borders(xlInsideVertical)
  146.         .LineStyle = xlContinuous
  147.         .ColorIndex = 0
  148.         .TintAndShade = 0
  149.         .Weight = xlThin
  150.     End With
  151.     With Selection.Borders(xlInsideHorizontal)
  152.         .LineStyle = xlContinuous
  153.         .ColorIndex = 0
  154.         .TintAndShade = 0
  155.         .Weight = xlThin
  156.     End With
  157.     Range("B3").Select
  158.     Worksheets(1).Select
  159.     Columns("A:B").Select
  160.     Selection.Delete Shift:=xlToLeft
  161.     Columns("B:B").Select
  162.     Selection.Delete Shift:=xlToLeft
  163.     Columns("D:D").EntireColumn.AutoFit
  164.     Range("D1").Select
  165.     ActiveCell.FormulaR1C1 = "Reg Date"
  166.     Range("D2").Select
  167.     Columns("D:D").EntireColumn.AutoFit
  168.     Range("E1").Select
  169.     ActiveCell.FormulaR1C1 = "Captain"
  170.     Columns("M:N").Select
  171.     Selection.Delete Shift:=xlToLeft
  172.     Columns("N:Y").Select
  173.     Selection.Delete Shift:=xlToLeft
  174.     Selection.Delete Shift:=xlToLeft
  175.     Range("P5").Select
  176.     ActiveWindow.SmallScroll ToRight:=-4
  177.     Columns("K:K").Select
  178.     Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  179.     Columns("L:L").Select
  180.     Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  181.     Range("K1").Select
  182.     ActiveCell.FormulaR1C1 = "$ Raised (Include Reg.)"
  183.     Range("K1").Select
  184.     Selection.Copy
  185.     Range("L1").Select
  186.     ActiveSheet.Paste
  187.     Range("K2").Select
  188.     Application.CutCopyMode = False
  189.     Range("K2").Select
  190.     ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
  191.     Range("K2").Select
  192.    
  193.     Selection.AutoFill Destination:=Range("K2", Range("K" & number))
  194.     Range("K2", Range("K" & number)).Select
  195.     Selection.Copy
  196.     Columns("K:K").Select
  197.     Application.CutCopyMode = False
  198.     Selection.Copy
  199.     Columns("L:L").Select
  200.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  201.         :=False, Transpose:=False
  202.     Columns("F:K").Select
  203.     Range("K1").Activate
  204.     Application.CutCopyMode = False
  205.     Selection.Delete Shift:=xlToLeft
  206.     Range("F1").Select
  207.     ActiveCell.FormulaR1C1 = "$ Raised (Include Reg.)"
  208.     Range("F2").Select
  209.     Columns("F:F").EntireColumn.AutoFit
  210.     Range("G1").Select
  211.     ActiveCell.FormulaR1C1 = "Goal"
  212.     Range("G2").Select
  213.     Worksheets(1).Activate
  214.     Range("H1").Select
  215.     ActiveCell.FormulaR1C1 = "Sent Emails"
  216.     Range("H2").Select
  217.     Columns("H:H").EntireColumn.AutoFit
  218.     With ActiveWindow
  219.         .SplitColumn = 0
  220.         .SplitRow = 1
  221.     End With
  222.     ActiveWindow.FreezePanes = True
  223.     Columns("A:F").Select
  224.     Columns("I:I").EntireColumn.AutoFit
  225.     Range("I3").Select
  226.     Columns("B:B").EntireColumn.AutoFit
  227.     Columns("C:C").EntireColumn.AutoFit
  228.     Columns("A:A").EntireColumn.AutoFit
  229.     Columns("A:I").Select
  230.     Selection.AutoFilter
  231.     Range("F2").Select
  232.     Columns("F:F").EntireColumn.AutoFit
  233.     ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields. _
  234.         Add Key:=Range("F1", Range("F" & number)), SortOn:=xlSortOnValues, Order:=xlDescending, _
  235.         DataOption:=xlSortTextAsNumbers
  236.     With ActiveWorkbook.Worksheets(1).AutoFilter.Sort
  237.         .Header = xlYes
  238.         .MatchCase = False
  239.         .Orientation = xlTopToBottom
  240.         .SortMethod = xlPinYin
  241.         .Apply
  242.     End With
  243.     Columns("F:F").Select
  244.     Selection.FormatConditions.AddColorScale ColorScaleType:=3
  245.     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
  246.     Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
  247.         xlConditionValueLowestValue
  248.     With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
  249.         .Color = 7039480
  250.         .TintAndShade = 0
  251.     End With
  252.     Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
  253.         xlConditionValuePercentile
  254.     Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
  255.     With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
  256.         .Color = 8711167
  257.         .TintAndShade = 0
  258.     End With
  259.     Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
  260.         xlConditionValueHighestValue
  261.     With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
  262.         .Color = 8109667
  263.         .TintAndShade = 0
  264.     End With
  265.     Range("G3").Select
  266.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:="<=10", _
  267.         Operator:=xlAnd
  268.     Range("J1").Select
  269.     ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,C[-4])"
  270.     Range("K1").Select
  271.     ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-5])"
  272.     Range("J1:K1").Select
  273.     Selection.Copy
  274.     Sheets("Segmented Results").Select
  275.     Range("B3:C3").Select
  276.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  277.         :=False, Transpose:=False
  278.     Columns("C:C").ColumnWidth = 12
  279.     Range("B4").Select
  280.     Worksheets(1).Select
  281.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6
  282.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:=">=10.01" _
  283.         , Operator:=xlAnd, Criteria2:="<=50"
  284.     Application.CutCopyMode = False
  285.     Selection.Copy
  286.     Sheets("Segmented Results").Select
  287.     Range("B4:C4").Select
  288.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  289.         :=False, Transpose:=False
  290.     Range("B5:C5").Select
  291.     Worksheets(1).Activate
  292.     Worksheets(1).Select
  293.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6
  294.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:=">=50.01" _
  295.         , Operator:=xlAnd, Criteria2:="<=100"
  296.     Application.CutCopyMode = False
  297.     Selection.Copy
  298.     Sheets("Segmented Results").Select
  299.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  300.         :=False, Transpose:=False
  301.     Worksheets(1).Select
  302.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:= _
  303.         ">=100.01", Operator:=xlAnd, Criteria2:="<=200"
  304.     Application.CutCopyMode = False
  305.     Selection.Copy
  306.     Sheets("Segmented Results").Select
  307.     Range("B6:C6").Select
  308.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  309.         :=False, Transpose:=False
  310.     Worksheets(1).Select
  311.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:= _
  312.         ">=200.01", Operator:=xlAnd, Criteria2:="<=500"
  313.     Application.CutCopyMode = False
  314.     Selection.Copy
  315.     Sheets("Segmented Results").Select
  316.     Range("B7:C7").Select
  317.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  318.         :=False, Transpose:=False
  319.     Worksheets(1).Select
  320.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:= _
  321.         ">=500.01", Operator:=xlAnd, Criteria2:="<=1000"
  322.     Application.CutCopyMode = False
  323.     Selection.Copy
  324.     Sheets("Segmented Results").Select
  325.     Range("B8:C8").Select
  326.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  327.         :=False, Transpose:=False
  328.     Worksheets(1).Select
  329.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6, Criteria1:= _
  330.         ">=1000.01", Operator:=xlAnd, Criteria2:="<=20000"
  331.     Application.CutCopyMode = False
  332.     Selection.Copy
  333.     Sheets("Segmented Results").Select
  334.     Range("B9:C9").Select
  335.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  336.         :=False, Transpose:=False
  337.     Worksheets(1).Activate
  338.     ActiveSheet.Range("$A$1", Range("I" & number)).AutoFilter Field:=6
  339.     Application.CutCopyMode = False
  340.     Selection.ClearContents
  341.     ActiveWindow.SmallScroll ToRight:=-4
  342.     Range("A1").Select
  343.     Sheets("Segmented Results").Activate
  344.     Range("B10").Select
  345.     ActiveCell.FormulaR1C1 = "=SUM(R[-7]C:R[-1]C)"
  346.     Selection.AutoFill Destination:=Range("B10:C10"), Type:=xlFillDefault
  347.     Range("C10").Select
  348.     Selection.Style = "Currency"
  349.     Range("B3:B10").Select
  350.     Selection.NumberFormat = "#,##0"
  351.     Range("B10:C10").Select
  352.     Selection.Font.Bold = True
  353.     Range("B12").Select
  354.     Application.ScreenUpdating = True
  355.     ActiveWorkbook.SaveAs Filename:="C:\Users\" & Environ$("Username") & "\Desktop\" & SheetName, _
  356.         FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  357.     ActiveWindow.WindowState = xlMaximized
  358. 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!