HUGE macro

P

project manager

this is really big, can it be made smaller?

Sub Pick_Um()

Select Case Range("D1").Value
Case 8
Call FOUR_ON_FOUR
Case 9
Call FIVE_ON_FOUR
Case 10
Call FIVE_ON_FIVE
Case 11
Call SIX_ON_FIVE
Case 12
Call SIX_ON_SIX
Case 13
Call SEVEN_ON_SIX
Case 14
Call SEVEN_ON_SEVEN

End Select

End Sub


Sub FIVE_ON_FIVE()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A6").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A7:A11").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub

Sub FOUR_ON_FOUR()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A5").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A6:A9").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub

Sub SIX_ON_SIX()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A7").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A8:A13").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub

Sub FIVE_ON_FOUR()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A6").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A7:A10").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub

Sub SIX_ON_FIVE()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A7").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A8:A12").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub



Sub SEVEN_ON_SIX()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A8").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A9:A14").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub

Sub SEVEN_ON_SEVEN()
Range("A2:C33").Select
ActiveWindow.SmallScroll Down:=-18
Range("A1:C20").Select
Application.AddCustomList ListArray:=Array("YES", "NO")
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("C2:C20") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="YES,NO", _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add
Key:=Range("B2:B20") _
, SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
..SetRange Range("A1:C20")
..Header = xlYes
..MatchCase = False
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
Range("F2:G17").Select
Selection.Delete Shift:=xlUp
Range("F2").Select
Range("A2:A8").Select 'COPY RANGE
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A9:A15").Select 'COPY RANGE
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="="""""""""""""

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Cells.FormatConditions.Delete
Range("F1:F15").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 255
..TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("G1:G14").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, _
Formula1:="=0"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
..PatternColorIndex = xlAutomatic
..Color = 65535
..TintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "NO"
Range("C2").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C3").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C4").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C5").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C6").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C7").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C8").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C9").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C10").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C11").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C12").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C13").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C14").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C15").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C16").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C17").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C18").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C19").Select
ActiveCell.FormulaR1C1 = "NO"
Range("C20").Select
ActiveCell.FormulaR1C1 = "NO"
Range("H1").Select
Application.CutCopyMode = False
End Sub
 
J

Jacob Skaria

Would you be able to explain this in few sentences. On an initial look you
can use FOR loop as in the below code to put NO from row 2 to 20.

For intTemp = 2 To 20
Range("C" & intTemp) = "NO"
Next

If this post helps click Yes
 
P

project manager

its to pick a team, so when the number of players in a list is 9 it randomly
sorts the list and copys and paste the names in the team colour list, the
only different in the FIVE_ON_FIVE and SIX_ON_FIVE is the size of the copy
and paste range.

d1 is the count of the number of players.
 
D

Don Guillett

Try this idea

Sub used1()
Range("c2:c" & Range("d1") + 1)="NO"
End Sub

You should also try to remove selections and unnecessary scrolls, etc.
 
J

joel

I improved the code and combined the macro into two macros.

Sub Pick_Um()

Select Case Range("D1").Value
Case 8
Call X_ON_X(4, 4)
Case 9
Call X_ON_X(5, 4)
Case 10
Call X_ON_X(5, 5)
Case 11
Call X_ON_X(6, 5)
Case 12
Call X_ON_X(6, 6)
Case 13
Call X_ON_X(7, 6)
Case 14
Call X_ON_X(7, 7)

End Select

End Sub


Sub X_ON_X(FirstSize As Integer, SecondSize As Integer)

Application.AddCustomList ListArray:=Array("YES", "NO")

With ActiveWorkbook.Worksheets("Sheet2")
.Sort.SortFields.Clear
.Sort.SortFields.Add _
Key:=Range("C2:C20"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
CustomOrder:="YES,NO", _
DataOption:=xlSortNormal

.Sort.SortFields.Add _
Key:=Range("B2:B20"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal

.Sort.SetRange Range("A1:C20") _
.Header = xlYes, _
.MatchCase = False, _
.Orientation = xlTopToBottom, _
.SortMethod = xlPinYin
.Apply

.Range("F2:G17").Delete Shift:=xlUp
.Range("A2:A" & (FirstSize + 1)).Copy
.Range("F2").PasteSpecial _
Paste:=xlPasteValues

.Range("A" & (FirstSize + 2) & ":A" & (FirstSize + SecondSize + 1)).Copy
.Range("G2").PasteSpecial _
Paste:=xlPasteValues

.Cells.FormatConditions.Delete

With .Range("F1:F15")

.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlNotEqual, _
Formula1:="=0"

.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With

With Range("G1:G14")
.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlNotEqual, _
Formula1:="=0"

.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With

.Range("C1:C20") = "NO"
End With
End Sub
 
P

project manager

it comes up with an errir when i run it.

joel said:
I improved the code and combined the macro into two macros.

Sub Pick_Um()

Select Case Range("D1").Value
Case 8
Call X_ON_X(4, 4)
Case 9
Call X_ON_X(5, 4)
Case 10
Call X_ON_X(5, 5)
Case 11
Call X_ON_X(6, 5)
Case 12
Call X_ON_X(6, 6)
Case 13
Call X_ON_X(7, 6)
Case 14
Call X_ON_X(7, 7)

End Select

End Sub


Sub X_ON_X(FirstSize As Integer, SecondSize As Integer)

Application.AddCustomList ListArray:=Array("YES", "NO")

With ActiveWorkbook.Worksheets("Sheet2")
.Sort.SortFields.Clear
.Sort.SortFields.Add _
Key:=Range("C2:C20"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
CustomOrder:="YES,NO", _
DataOption:=xlSortNormal

.Sort.SortFields.Add _
Key:=Range("B2:B20"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal

.Sort.SetRange Range("A1:C20") _
.Header = xlYes, _
.MatchCase = False, _
.Orientation = xlTopToBottom, _
.SortMethod = xlPinYin
.Apply

.Range("F2:G17").Delete Shift:=xlUp
.Range("A2:A" & (FirstSize + 1)).Copy
.Range("F2").PasteSpecial _
Paste:=xlPasteValues

.Range("A" & (FirstSize + 2) & ":A" & (FirstSize + SecondSize + 1)).Copy
.Range("G2").PasteSpecial _
Paste:=xlPasteValues

.Cells.FormatConditions.Delete

With .Range("F1:F15")

.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlNotEqual, _
Formula1:="=0"

.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With

With Range("G1:G14")
.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlNotEqual, _
Formula1:="=0"

.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With

.Range("C1:C20") = "NO"
End With
End Sub
 
P

project manager

..Sort.SetRange Range("A1:C20") _
..Header = xlYes, _
..MatchCase = False, _
..Orientation = xlTopToBottom, _
..SortMethod = xlPinYin
..Apply
 
J

joel

I see what I did wrong. I usually do my sorts a little different then the
wayyou did it. I normally do it in one instruction

from
..Sort.SetRange Range("A1:C20") _
..Header = xlYes, _
..MatchCase = False, _
..Orientation = xlTopToBottom, _
..SortMethod = xlPinYin
..Apply

with .Sort
.SetRange Range("A1:C20")
.Header = xlYes
.MatchCase = False
.orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
end with


I usually do it without the with like this. I kind of mixed the 2 methods
and got it wrong.

.Range("A1:C20").Sort _
Header = xlYes, _
MatchCase = False , _
orientation = xlTopToBottom, _
SortMethod = xlPinYin
 
P

project manager

now an error on

..FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
 
D

Dana DeLouis

Case 8
Just an idea. If the op expands the number of inputs, does it follow
the same pattern?

x = CLng(Range("D1")) 'Make sure it's an integer
Select Case x
Case 8 To 14 ' or more...
Call X_ON_X((x + 1) \ 2, x \ 2)
Case Else
'??
End Select

= = =
Dana DeLouis

<snip>
 
J

joel

I think in this case the select statement makes the code much easier to
understand. Reducing the number of lines of code really doesn't have any
advantage.
 
P

project manager

its not working at all??? its not sorting, copying or pasting???

i put a break in the first line and F8'ed it through...

just nothing
 
J

joel

I'll take a look at this tonight. Usually these problems are when more that
one workbook is opened. the code is using Activeworkbook. Maybe this should
be changed to Thisworkbook (the book with the macro) rather than
actrtiveworkbook.

The other possibility it the range in the Pick_Um code doesn't specify a
worksheet. If D1 is 0 the code will not work (wrong workshet selected). You
are right the sort should be working which implies it is not reading the
value in D1 because the wrong worksheet is active.

Sub Pick_Um()

Select Case Range("D1").Value
Case 8
Call X_ON_X(4, 4)
Case 9
Call X_ON_X(5, 4)
Case 10
Call X_ON_X(5, 5)
Case 11
Call X_ON_X(6, 5)
Case 12
Call X_ON_X(6, 6)
Case 13
Call X_ON_X(7, 6)
Case 14
Call X_ON_X(7, 7)

End Select

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top