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
Click to expand...
 
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
 
J

joel

We are close to the end. I fixed this problem once in the code and did see
the problem the 2nd time. I is very tough to make a lot of changes and get
it perfect the 1st time. 've done changes like this a lot and usually get it
perfect the 1st time.

from
..FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
to
..FormatConditions(.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
 

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

Similar Threads

conditional format based on column statistics and loop over columns 1
Problem with relative reference. 1
Highlight Row Based On Condition-So close 3
getting Run-time error '1004' Select Method of Worksheet Classfailed 0
Conditional Formatting Code 1
Macro Help 3
conditional formatting 1004 errors 5
Range Selection help (Formatting) 2

Top