Below is what I came up with for the decade portion of the project. I'm having issues with menu validation and when it selects the first top 100 it skips the first row. Any help would be great!
Public Sub Menu()
Dim menuOpt As Integer
Dim msg As String
Const minYear As Integer = 1940
Const maxYear As Integer = 2050
msg = "Enter 4 Digit Year (ie 1940) or a single 9 for the Decade (type 777 to end): "
menuOpt = 0
menuOpt = InputBox(msg)
If menuOpt = 9 Then
Call decadeProcess(menuOpt)
End If
If menuOpt = 777 Then
Exit Sub
End If
If menuOpt >= minYear And menInt <= 2050 Then
Call yearProcess(menuOpt)
End If
End Sub
Sub decadeProcess(menuOpt As Integer)
Dim i As Integer
Dim setDecade As Integer
Dim setYear As Integer
Dim Lastrow As Long
Dim rng As Range
Dim rng2 As Range
Dim rngFormula As Range
Dim rowData As Long
Dim colData As Long
Dim cnt As Integer
setDecade = 0
setYear = 0
'message = "Decade Process"
'MsgBox (message & "Variable: " & menuOpt)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Decade" Then
exists = True
Sheets("Decade").Select
ActiveSheet.Cells.Select
Selection.ClearContents
End If
Next i
If Not exists Then
Worksheets.Add.Name = "Decade"
End If
'Set Decade
Sheets("Master").Select
Sheets("Master").Columns(1).NumberFormat = "0"
Sheets("Master").Columns(2).NumberFormat = "0"
Worksheets("Master").AutoFilterMode = False
setDecade = Worksheets("Master").Range("A1").Value
Do Until setYear = 10
Sheets("Master").Select
With ActiveSheet.Range("A1:M1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:=setDecade
.AutoFilter Field:=2, Criteria1:=">=1", _
Operator:=xlAnd, Criteria2:="<=100"
End With
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Lastrow = Worksheets("Decade").Cells(Rows.Count, 1).End(xlUp).Row
If Lastrow = 1 Then
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
Destination:=Worksheets("Decade").Range("A" & Lastrow)
Else
Lastrow = Lastrow + 1
rng.Offset(1, 0).Resize(rng.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("Decade").Range("A" & Lastrow)
End If
End If
'ActiveSheet.ShowAllData
setYear = setYear + 1
setDecade = setDecade + 1
Loop
Worksheets("Decade").Activate
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Formula = "=RANDBETWEEN(1,765675765)"
' Set the ranges
Set rng = ActiveCell
Set rngData = rng.CurrentRegion
' Set the row and column variables
rowData = rngData.CurrentRegion.Rows.Count
colData = rng.Column
' Set the formula range and fill down the formula
Set rngFormula = rngData.Offset(0, colData - 1).Resize(rowData, 1)
rngFormula.FillDown
cnt = 0
Do Until cnt = 2
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
cnt = cnt + 1
Loop
With ActiveSheet
.Range("A1").EntireColumn.Delete
End With
Call InsertDecadeDrops
End Sub
Bookmarks