Please Help with Copy/Paste and creating sheets depending on user input

**rrstull** · 06-13-2013, 05:15 PM

Hello!

I'm new to VBA and have worked on this for hours trying to figure it out. I need some help. I do this one year at a time and it takes me forever. I'm trying to make the process quicker. It basically is a lot of copy and pasting. I've attached an example spreadsheet.

This is what I'm trying to do:

User enters a year (1950 for example). It follows the Year Path
User enters the word "decade". It follows the Decade Path.

The year or the word "Decade" will need to be a global variable to pass to other modules below and will be needed on the "Year Drops" Sheet. I used sheetString as a variable name. It can be changed. I need the cells formulas fixed on the sheet "Year Drops" to reflect the variable name.

Year Path

1. Clears all contents from sheet "100+"
2. Creates a sheet with the Year as the name.
3. It will select a range of rows from Sheet "Master" where Column A = the Year and Column B => 1 and <=100 and copy them to the newly created sheet.
4. It will randomize the order of those rows and copy and paste them 4 times. You will have 4 sets of the same information which would be about 400 rows. ( I randomize by inserting a new column giving each cell a random number and sorting from lowest to greatest and then deleting the column)
5. Now go back to Master sheet and select where Column A = the Year and Column B => 101 and <=305 and copy them to Sheet "100+"
6. Randomize the order of the rows and Bold the font of all the rows on sheet "100+"
7. Call Sub AAB_Rotation, Call Sub InsertDrops, Call Sub Cp1(), Call Sub Cp2(), Call Sub Cp3(), Call Sub Cp4(), Call Sub Cp5(), Call Sub RandomizePSAs(), and Call Sub Psa()

Decade Path

1. Creates a sheet called "Decade".
2. It will find the top 100 from each year and copy the to the sheet "Decade" where Column A = the Year and Column B => 1 and <=100
3. Randomize the order of all the rows on the sheet "Decade" twice
5. Call Sub InsertDecadeDrops, Call Sub Cp1(), Call Sub Cp2(), Call Sub Cp3(), Call Sub Cp4(), Call Sub Cp5(), Call Sub RandomizePSAs(), and Call Sub Psa()

Sub InsertDrops()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
     Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("Year Drops")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 5
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    
    Call Cp1
End Sub

Sub InsertDecadeDrops()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
     Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("Decade Drops")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 5
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    Call Cp1
End Sub


Sub AAB_Rotation()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
     Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("100+")
    iSong = 3
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 3
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    InsertDrops
End Sub

Sub Cp1()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
     Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("CP 1")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 6
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    
    Call Cp2
End Sub


Sub Cp2()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
   Application.ScreenUpdating = False
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("CP 2")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 7
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    
    Call Cp3
End Sub


Sub Cp4()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
   Application.ScreenUpdating = False
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("CP 4")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 9
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    
    Call Cp5
End Sub


Sub Cp5()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
    Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("CP 5")
    iSong = 5
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 10
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    Call Psa
End Sub


Sub Psa()
    Dim wsSong As Worksheet, wsDrop As Worksheet
    Dim iSong As Long, iDrop As Long
    
    Application.ScreenUpdating = False
    
    Set wsSong = Worksheets(sheetString)
    Set wsDrop = Worksheets("PSAs")
    iSong = 40
    iDrop = 1
    While wsSong.Range("A" & iSong) <> ""
        wsSong.Rows(iSong).Insert
        wsDrop.Rows(iDrop).Copy Destination:=wsSong.Rows(iSong)
        iSong = iSong + 41
        iDrop = iDrop + 1
        If wsDrop.Range("A" & iDrop) = "" Then iDrop = 1
    Wend
    MsgBox "PSA Placement Done!"
End Sub


Sub RandomizePSAs()
'
' RandomizePSAs Macro
'

'
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=RANDBETWEEN(1,1245145145)"
    Selection.AutoFill Destination:=Range("A1:A63")
    Range("A1:A63").Select
    Cells.Select
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("PSAs").Sort
        .SetRange Range("A1:R114")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("PSAs").Sort
        .SetRange Range("A1:R114")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("PSAs").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("PSAs").Sort
        .SetRange Range("A1:R114")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
End Sub

**FDibbins** · 06-13-2013, 05:19 PM

Hi and welcome to the forum

We would love to help you with your question, but 1st, in accordance with forum rule, please rename your thread to something more meaningful, that actually describes your problem.

Because thread titles are used in searching the forum it is vital they be written to accurately describe your thread content or overall objective using ONLY search friendly key words. That is, your title used as search terms would return relevant results.

Also, many members will look at a thread title, and if it is of interest to them, or it falls within their area of expertese, they might only open those threads.

Look at it this way...if you typed that title into google, what would you expect to get back?
To change a Title on your post, click EDIT on you're 1st post, then Go Advanced and change your title

**rrstull** · 06-16-2013, 03:46 PM

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