How best to streamline this code?

[goldenvision]

I'm looking for some tips on how best to streamline the below portion of code.

I have it working for one worksheet ("BA Bush"). I now need to repeat this for another 16 sheets and I want to move away from having pages and pages of repeating commands. I have seen some quite nice code on this forum and I was looking for some pointers on how best to streamline this.

Thanks in advance.

In a nutshell the code is reading cell A1 which contains the current month, then dependant on that value, copies the formula from cells D4:E8 to upto 17 other cells.

Sub CopyFormulas()
'copy summary formula across BA Bush
Sheets("BA Bush").Activate
Range("D4:E8").Select
Selection.Copy
If Range("A1").Value = "01/08/2007" Then
Range("F4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/09/2007" Then
Range("F4, H4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/10/2007" Then
Range("F4, H4, J4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/11/2007" Then
Range("F4, H4, J4, L4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/12/2007" Then
Range("F4, H4, J4, L4, N4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/01/2008" Then
Range("F4, H4, J4, L4, N4, P4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/02/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/03/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/04/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/05/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/06/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/07/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/08/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4, AD4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/09/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4, AD4, AF4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/10/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4, AD4, AF4, AH4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/11/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4, AD4, AF4, AH4, AJ4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
If Range("A1").Value = "01/12/2008" Then
Range("F4, H4, J4, L4, N4, P4, R4, T4, V4, X4, Z4, AB4, AD4, AF4, AH4, AJ4, AK4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If '08/07
    End If '09/07
        End If '10/07
            End If '11/07
                End If '12/07
                    End If '01/08
                        End If '02/08
                            End If '03/08
                                End If '04/08
                                    End If '05/08
                                        End If '06/08
                                    End If '07/08
                                End If '08/08
                            End If '09/08
                        End If '10/08
                    End If '11/08
                End If '12/08
End Sub

 

[DougStroud]

Do you want this to loop through all the sheets in the workbook and perform the same exact instructions on each sheet?

 

[goldenvision]

Yes

 

[goldenvision]

Yes

 

[njimack]

The below code should point you in the right direction...

Sub CopyFormulas()
Dim ws As Worksheet


For Each ws In ActiveWorkbook.Sheets

    With ws
        Select Case .Range("A1")

            Case "01/08/2007": .Range("D4:D8").Copy Destination:=.Range("F4")
            Case "01/09/2007": .Range("D4:D8").Copy Destination:=.Range("F4, H4")
            Case "01/10/2007": .Range("D4:D8").Copy Destination:=.Range("F4, H4, J4")

        End Select
    End With
    
Next
End Sub

 

[DiscoPistol]

Is this what you're after?

Dim ws As Worksheet 
For Each ws In Worksheets 
ws.Select 

Code

next ws
End Sub

DP

 

[Peter_SSs]

goldenvision

This has no error checking (to see that A1 on each sheet contains a date from "01/08/2007" to "01/12/2008"), but that can be added if need be. Thought I would just see if the code basically does the right thing first.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> CopyFormulas()
    <SPAN style="color:#00007F">Dim</SPAN> ws <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> Multiple <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    
    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> ws <SPAN style="color:#00007F">In</SPAN> Worksheets
        <SPAN style="color:#00007F">With</SPAN> ws
            Multiple = Month(.Range("A1").Value) - 7 + 12 * (Year(.Range("A1").Value) - 2007)
            .Range("D4:E8").Copy Destination:=.Range("F4").Resize(5, Multiple * 2)
        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
    <SPAN style="color:#00007F">Next</SPAN> ws
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[GlennUK]

Very good Peter, except I would have used this to get "Multiple":

Multiple= DateDiff("m", #7/1/2007#, Range("A1"))

 

[Norie]

goldenvision

Try this.

Sub CopyFormulas()
Dim ws As Worksheet
Dim rngDst As Range
Dim rngSrc As Range
Dim I As Long

    For Each ws In Worksheets
        Set rngSrc = ws.Range("D4:E8")
        Set rngDst = ws.Range("F4")
        For I = 0 To DateDiff("m", DateSerial(2007, 8, 1), ws.Range("A1"))
            If I <> 16 Then
                Set rngDst = Union(rngDst, ws.Range("F4").Offset(, I * 2))
            Else
                Set rngDst = Union(rngDst, ws.Range("AK4"))
            End If
        Next I
        rngSrc.Copy rngDst
        
    Next ws
    
End Sub

 

[goldenvision]

Thanks for all of the replies. How can this be tweaked to run through a selection of worksheets rather than everyone?