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