Repeating VBA Lines/cleanup

Johnis2Deezy

New Member
Joined
Feb 17, 2014
Messages
7
I am trying to write a macro that will create a report that can be filled in for an entire year with a tab per week, tab for a summary for the month, and tab for summary of each quarter. The reason for this is that the report is probably going to have elements added later on. So, rather than adding something new to each spreadsheet, I would add it to the template and then recreate the report. Ive attached the file, and if you run the macro you can see whats going on. My question is,

i have a ton of repeated code, especially in the case statements. I have been trying to figure out how i could use more loops but i think i am to far in the hole and i need to clean up the code i already have. Does anybody have any suggestions?

heres the file

Code:
Sub Create_Spreadsheets()



Dim Tmp As String
Dim tmp2 As String
Dim Tmp3 As String
Dim Dtname As Date
Dim i As Integer
Dim ii As Integer
Dim iii As Integer
Dim e As Integer
Dim wbad(4) As String, werror(4) As String, wgood(4) As String, wprep(4) As String
Dim wksht As String




Tmp = Sheets(1).Name
tmp2 = Sheets(2).Name
Tmp3 = Sheets(3).Name
Dtname = #2/2/2014#
ii = 1
iii = 1
e = 0


'Week Tabs
For i = 1 To 52
    Worksheets(Tmp).Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "WK" & i & " " & Format(Dtname, "mmm")
    Sheets(Sheets.Count).Range("B1").Value = "Week #" & i
    ' get link cell names
    wksht = Sheets(Sheets.Count).Name
    wbad(e) = "='" & wksht & "'!I13"
    werror(e) = "='" & wksht & "'!I15"
    wgood(e) = "='" & wksht & "'!I17"
    wprep(e) = "='" & wksht & "'!I19"
    'dates
    Sheets(Sheets.Count).Range("b8").Activate
    For a = 0 To 6
            ActiveCell.Value = Dtname
            ActiveCell.Offset(0, 1).Activate
            Dtname = Dtname + 1
            Next
        e = e + 1
    'P tabs and Q tabs
    Select Case i
        Case 4
           Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " " & " Feb"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = n1 To n2
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 9
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Mar"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 5 To 9
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 4
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 13
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Apr"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 10 To 13
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
            Worksheets(Tmp3).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "Q" & iii
            Sheets(Sheets.Count).Range("B1").Value = "Quarter #" & iii
            Sheets(Sheets.Count).Tab.ColorIndex = 8
            iii = iii + 1
        Case 17
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " May"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 14 To 17
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 22
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Jun"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 18 To 22
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 4
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 26
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Jul"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 23 To 26
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
            Worksheets(Tmp3).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "Q" & iii
            Sheets(Sheets.Count).Range("B1").Value = "Quarter #" & iii
            Sheets(Sheets.Count).Tab.ColorIndex = 8
            iii = iii + 1
        Case 30
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Aug"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 27 To 30
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 35
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Sep"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 31 To 35
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 4
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 39
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Oct"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 36 To 39
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
            Worksheets(Tmp3).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "Q" & iii
            Sheets(Sheets.Count).Range("B1").Value = "Quarter #" & iii
            Sheets(Sheets.Count).Tab.ColorIndex = 8
            iii = iii + 1
        Case 43
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Nov"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 40 To 43
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
            
        Case 48
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Dec"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 44 To 48
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 4
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
        Case 52
            Worksheets(tmp2).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "P" & ii & " Jan"
            Sheets(Sheets.Count).Range("B1").Value = "Period #" & ii
            Sheets(Sheets.Count).Tab.ColorIndex = 6
            ' header names
            Sheets(Sheets.Count).Range("b8").Activate
            For a = 49 To 52
                ActiveCell.Value = "WK " & a
                ActiveCell.Offset(0, 1).Activate
            Next
            ii = ii + 1
            ' link cells
            Sheets(Sheets.Count).Range("B13").Activate
            e = 0
            For e = 0 To 3
                ActiveCell.Value = wbad(e)
                ActiveCell.Offset(2, 0).Value = werror(e)
                ActiveCell.Offset(4, 0).Value = wgood(e)
                ActiveCell.Offset(6, 0).Value = wprep(e)
                ActiveCell.Offset(0, 1).Activate
            Next
            e = 0
            Worksheets(Tmp3).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "Q" & iii
            Sheets(Sheets.Count).Range("B1").Value = "Quarter #" & iii
            Sheets(Sheets.Count).Tab.ColorIndex = 8
            iii = iii + 1
        End Select
    Next
   
    
End Sub
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Hi, and welcome to the forum.

When you find yourself repeating code it is a good indication that you could write a separate procedure to do that task. Then call the procedure each time you need it. See the sample code below.

I have coded some of the CopyTemplate() procedure.
Note in the commented out code how you can group the test values in a Select Case statement.
Hope this helps.
Bertie

Rich (BB code):
Sub CreateSpreadsheets02()
   Dim newPeriod As Long
   Dim newWeek As Long
   Dim newQuarter As Long
   Dim Dtname As Date
   Dim i As Long
   
   Dtname = #2/2/2014#


   For i = 1 To 52
      newWeek = newWeek + 1
      CopyTemplate newWeek, Dtname
            
      'Select Case i  'Period
       '  Case 4, 9, 13, 17, 22   'etc,
       '    newPeriod = newPeriod + 1
            'CopyPeriod newPeriod, dtnamw, 6  'where 6 = tab colour
      'End Select
      
      'Select Case i  'Quarter
       '  Case 13, 26, 39, 52
       '     newQuarter = newQuarter + 1
            'copy quarter template
      'End Select
   
      Dtname = Dtname + 7
   Next i
End Sub




Private Sub CopyTemplate(ByVal WeekNumber As Long, _
                         ByVal StartDate As Date)
     
   Worksheets("Template").Copy After:=Sheets(Sheets.Count)
   With ActiveSheet
      .Name = "WK" & WeekNumber & " " & Format(StartDate, "mmm")
      .Range("B2").Value = "Week #" & WeekNumber
      .Range("B8").Value = StartDate
      .Range("C8:H8").Formula = "=B8+1"
   End With
End Sub




Private Sub CopyPeriod(ByVal WeekNumber As Long, _
                       ByVal StartDate As Date, _
                       ByVal TabColour As Long)
     
   'Worksheets("Template-Period").Copy After:=Sheets(Sheets.Count)


End Sub
 
Last edited:
Upvote 0
Thanks Bertie!! That saves a ton a lines and makes much easier to add to. I don't really understand what the byval declaration means or how it works. I looked it up but it still doesn't make much sense.
 
Upvote 0
ByVal means you are sending the value assigned to a variable to the procedure.
You can change this value within the scope of the procedure, but in its parent procedure it retains its original value.

ByRef means you are sending a procedure the reference to the memory where the value assigned to the variable is stored.
As you know the memory address you can change the value stored there.
The variable is changed throughout the scope of the module containing the code.

So, ByVal = you don't want to change the value assigned to the variable.
ByRef = when you need to update a value assigned to the variable.
 
Upvote 0
Hey Bertie,

So I applied a lot of your code to the mix and finished it. I tried using a dynamic array to link the cells together. This works pretty well, but just for the sake of learning, do have a better idea how to link the cells?

Code:
Sub CreateSpreadsheets02()   Dim newPeriod As Long
   Dim newWeek As Long
   Dim newQuarter As Long
   Dim Dtname As Date
   Dim Periodnumber As Long
   Dim i As Long
   Dim pDataRange() As Variant
   Dim qDataRange() As Variant
   Dim wknm As String
   
   Dtname = #2/2/2014#
    'totals
    pDataRange = Array("i13", "i14", "i15", "i16", "i17", "i20", "i21", "I22", "i23", "i24", "i25", "i26", "i27", "i28")
    qDataRange = Array("g13", "g14", "g15", "g16", "g17", "g20", "g21", "g22", "g23", "g24", "g25", "g26", "g27", "g28")
    
    
    
   For i = 1 To 52
      newWeek = newWeek + 1
      CopyTemplate newWeek, Dtname
            
      Select Case i  'Period
          Case 4, 13, 17, 26, 30, 39, 43, 52
           newPeriod = newPeriod + 1
            CopyPeriod4 newPeriod, Dtname, 6, i  'where 6 = tab colour
            'Link Cells
            For Row = 1 To 4
                For d = LBound(pDataRange) To UBound(pDataRange)
                    Range(pDataRange(d)).Offset(0, (-8 + Row)).Activate
                    ActiveCell.Value = "='" & Sheets(Sheets.Count - 5 + Row).Name & "'!" & pDataRange(d)
                Next
            Next
      End Select
     
      Select Case i
         Case 9, 22, 35, 48
          newPeriod = newPeriod + 1
           CopyPeriod5 newPeriod, Dtname, 6, i
           'Link Cells
            For Row = 1 To 5
                For d = LBound(pDataRange) To UBound(pDataRange)
                    Range(pDataRange(d)).Offset(0, (-8 + Row)).Activate
                    ActiveCell.Value = "='" & Sheets(Sheets.Count - 6 + Row).Name & "'!" & pDataRange(d)
                Next
            Next
      End Select
      
      Select Case i  'Quarter
         Case 13, 26, 39, 52
            newQuarter = newQuarter + 1
            CopyQuarter newQuarter, Dtname, 8, Periodnumber 'where 8 = tab colour
            'Link Cells
            For Row = 1 To 3
                For d = LBound(qDataRange) To UBound(qDataRange)
                    Range(qDataRange(d)).Offset(0, (-6 + Row)).Activate
                    Select Case Row
                        Case 1
                        ActiveCell.Value = "='" & Sheets(Sheets.Count - 12).Name & "'!" & qDataRange(d)
                        Case 2
                        ActiveCell.Value = "='" & Sheets(Sheets.Count - 6).Name & "'!" & qDataRange(d)
                        Case 3
                        ActiveCell.Value = "='" & Sheets(Sheets.Count - 1).Name & "'!" & qDataRange(d)
                    End Select
                Next
            Next
      End Select
   
      Dtname = Dtname + 7
   Next i
End Sub








Private Sub CopyTemplate(ByVal WeekNumber As Long, _
                         ByVal Startdate As Date)
     
   Worksheets("Template").Copy after:=Sheets(Sheets.Count)
   With ActiveSheet
      .Name = "WK" & WeekNumber & " " & Format(Startdate, "mmm")
      .Range("B1").Value = "Week #" & WeekNumber
      .Range("B8").Value = Startdate
      .Range("B8").Select
    End With
Selection.AutoFill Destination:=Range("B8:H8"), Type:=xlFillDates




End Sub








Private Sub CopyPeriod4(ByVal PNumber As Long, _
                       ByVal Startdate As Date, _
                       ByVal Tabcolour As Long, _
                       ByVal Weekname As Long)
     
   Worksheets("Template-Period").Copy after:=Sheets(Sheets.Count)
   With ActiveSheet
        .Name = "P" & PNumber & Format(StateDate, "mmm")
        .Tab.ColorIndex = Tabcolour
        .Range("B1").Value = "Period #" & PNumber
        .Range("B9").Value = "Week #" & Weekname - 3 'naming headers
        .Range("C9").Value = "Week #" & Weekname - 2
        .Range("D9").Value = "Week #" & Weekname - 1
        .Range("E9").Value = "Week #" & Weekname
   End With


End Sub


Private Sub CopyPeriod5(ByVal PNumber As Long, _
                       ByVal Startdate As Date, _
                       ByVal Tabcolour As Long, _
                       ByVal Weekname As Long)
     
   Worksheets("Template-Period").Copy after:=Sheets(Sheets.Count)
   With ActiveSheet
        .Name = "P" & PNumber & Format(StateDate, "mmm")
        .Tab.ColorIndex = Tabcolour
        .Range("B1").Value = "Period #" & PNumber
        .Range("B9").Value = "Week #" & Weekname - 4 'naming headers
        .Range("C9").Value = "Week #" & Weekname - 3
        .Range("D9").Value = "Week #" & Weekname - 2
        .Range("E9").Value = "Week #" & Weekname - 1
        .Range("F9").Value = "Week #" & Weekname
   End With
            
End Sub


Private Sub CopyQuarter(ByVal QNumber As Long, _
                        ByVal Startdate As Long, _
                        ByVal Tabcolour As Long, _
                        ByRef Periodnumber As Long)


    Worksheets("Template-Quarter").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = "Q" & QNumber
        .Tab.ColorIndex = Tabcolour
        .Range("B1").Value = "Quarter #" & QNumber
    End With
        Periodnumber = Periodnumber + 1
        Range("B9").Value = "Period #" & Periodnumber
        Periodnumber = Periodnumber + 1
        Range("c9").Value = "Period #" & Periodnumber
        Periodnumber = Periodnumber + 1
        Range("D9").Value = "Period #" & Periodnumber
        
End Sub
 
Upvote 0

Forum statistics

Threads
1,216,111
Messages
6,128,899
Members
449,477
Latest member
panjongshing

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top