Alternative to using a slow loop!!

[P1R]

hi all,

Im hoping that someone can help me improve the efficiency of the below code. It currently takes about 20-25 seconds to run, which would be acceptable if it only had to run once, but it has to run 10+ times, which is blowing the processing time out into minutes which is far to long.

The code is basically taking information from a roster template (ie names in the left column, dates along the top with a start,finish and total time under each day) and copy it into a simple list with a preset set of dates that can be stored and easily analysed.

Currently my biggest problem (as far as i can tell), is that the system is constantly accessing multiple different cells in every iteration of the loop, so i think i need a way of either significantly cutting down the number of times i access cells in each iteration or find a way to elimnate one/both of the loops:

Function COPY_WEEK_A(ByVal WEEK As Integer) As Integer
On Error GoTo 0:

Dim x As Integer
Dim y As Integer
Dim AVAL_COUNT As Integer
Dim DAY As String
Dim Found, Temp_Range As Range
Dim lookup_val As String

Application.ScreenUpdating = False
With Worksheets("AVAILABILITY_DROP")
    MsgBox Format(Names("FIRST_DAY").RefersToRange.Value, "0")
    DAY = Format(Names("FIRST_DAY").RefersToRange.Value, "0") + ((WEEK * 7) - 7)
    For x = 0 To 6
        Set Found = Find_Range(DAY + x, Names("AVL_TIME").RefersToRange)
        If Not Found Is Nothing Then Found.EntireRow.Delete
    Next x
    Worksheets("LIST_DUMPS").Calculate
    AVAL_COUNT = Names("AVL_COUNT").RefersToRange.Value + 4
    For x = 12 To 30 Step 3
        For y = 16 To Names("NO_STAFF").RefersToRange.Value + 15
        If Worksheets("AVAILABILITY").Cells(y, x).Text <> "" And Worksheets("AVAILABILITY").Cells(y, 2).Text <> "" Then
            .Cells(AVAL_COUNT, 1) = Worksheets("AVAILABILITY").Cells(y, 2).Value & DAY
            .Cells(AVAL_COUNT, 2) = Worksheets("AVAILABILITY").Cells(y, 2).Value
            .Cells(AVAL_COUNT, 3) = DAY
            If Worksheets("AVAILABILITY").Cells(y, x) = "n" Then
                .Cells(AVAL_COUNT, 4) = 0.9993
                .Cells(AVAL_COUNT, 5) = 0
            Else
                .Cells(AVAL_COUNT, 4) = Worksheets("AVAILABILITY").Cells(y, x)
                .Cells(AVAL_COUNT, 5) = Worksheets("AVAILABILITY").Cells(y, x + 1)
            End If
            AVAL_COUNT = AVAL_COUNT + 1
        End If
        Next y
        DAY = DAY + 1
    Next x
    .Cells(AVAL_COUNT, 1).Resize(Temp_Range.Rows.Count, 5) = Temp_Range.Cells
End With
Worksheets("LIST_DUMPS").Calculate
COPY_WEEK = 0
Exit Function

0:
Application.ScreenUpdating = True
COPY_WEEK = 1
End Function

thanks in advance for your help