Please Help Me Speed Up My Code

[Alfred12]

Hello all --

I hadn't even heard of VBA two weeks ago, but with much struggle, and some help from the kind folks here (thanks!), I've got my code working exactly the way I want.

But it is really sloooow! I assume it is the copying and pasting that is the culprit, but perhaps it is something (or somethings) else. I am sure there is a more elegant way to write this that might speed it up some. Any thoughts would be greatly appreciated. Thanks!

Alfred

Sub Compile()
    Dim S As Integer
    Dim z As Integer
    Dim i As Integer
    Worksheets(1).Activate
    Range("A2:J35").ClearContents
    For z = 1 To 5
        For S = 2 To Sheets.Count
            Worksheets(S).Activate
            For i = 1 To 25
                If Worksheets(S).Cells(i, 5).Value = z Then
                    If Worksheets(S).Cells(i, 6).Value = "yes" Then
                        Worksheets(1).Activate
                        Range("A500").End(xlUp).Offset(1, 0) = z
                        Worksheets(S).Cells(i, 1).Copy
                        Worksheets(1).Activate
                        Range("A500").End(xlUp).Offset(0, 1).Select
                        ActiveSheet.Paste
                        Worksheets(S).Cells(i, 7).Copy
                        Worksheets(1).Activate
                        Range("A500").End(xlUp).Offset(0, 2).Select
                        ActiveSheet.Paste
                        Worksheets(S).Cells(i, 8).Copy
                        Worksheets(1).Activate
                        Range("A500").End(xlUp).Offset(0, 3).Select
                        ActiveSheet.Paste
                        Worksheets(S).Cells(i, 9).Copy
                        Worksheets(1).Activate
                        Range("A500").End(xlUp).Offset(0, 4).Select
                        ActiveSheet.Paste
                    End If
                End If
            Next i
        Next S
        Worksheets(1).Activate
        Range("A100").End(xlUp).Offset(1, 0) = " "
    Next z
    Worksheets(1).Activate
End Sub

 

[VoG]

Try without all that activating and selecting. For example

Worksheets(1).Activate
Range("A500").End(xlUp).Offset(1, 0) = Z
Worksheets(S).Cells(i, 1).Copy
Worksheets(1).Activate
Range("A500").End(xlUp).Offset(0, 1).Select
ActiveSheet.Paste

could be replaces with

Worksheets(1).Range("A500").End(xlUp).Offset(1, 0) = Z
Worksheets(S).Cells(i, 1).Copy Destination:=Worksheets(1).Range("A500").End(xlUp).Offset(0, 1)

 

[Alfred12]

I'll give that a go. Thanks VoG!