Looping through data to reorganize data very slow

[amros]

Hi all,

I have one sheet where I save data in one row at a time. Now I have written code to create a summary table of that data. Each row contains information for three production locations. Part of that information is the same for each location, other parts are specific to the location. For that reason I loop through all the rows in the sheet where I save data. Within that loop I loop three times within that loop to get the information for each location.
Capture.JPG

I attached an image which hopefully clarifies what I want to achieve.

The code below works but it is very slow and gets substantially slower if the number of rows increase (number of rows x 3).

Sub summaryUpdate()

Dim sr, dr, l As Integer
Dim plant As Variant

Application.ScreenUpdating = False

numRows = Worksheets("SavedSpecs").Cells(Rows.Count, "Z").End(xlUp).Row

dr = 5

For sr = 2 To numRows

    Set summarySpecRng = Worksheets("SavedSpecs").Range("Z" & sr & ",C1,AJ" & sr & ",V" & sr & ",AHV" & sr & ",AMB" & sr & ",ALZ" & sr & ",AMA" & sr)
    
    x = summarySpecRng.Cells.Count
    
    '~~> Resize the array to hold the data
    ReDim summarySpecAr(1 To x)

    x = 1

    '~~> Store the values from that range into the array
    For Each aCell In summarySpecRng.Cells
        summarySpecAr(x) = aCell.Value
        x = x + 1
    Next aCell

    '~~> Match production locations with the number in variable l for the sake of clarity
    aa = 1
    bb = 2
    mx = 3

    '~~> Loop through production locations (AA, BB, CC). Variable l stands for location
    For l = 1 To 3
        
        If l = aa Then
            plant = "AA"
            Cost = Worksheets("SavedSpecs").Range("AMD" & sr) + Worksheets("SavedSpecs").Range("AMF" & sr)
            Set pricingRng = Worksheets("SavedSpecs").Range("AMW" & sr & ",AMX" & sr & ",ANB" & sr)
        ElseIf l = bb Then
            plant = "BB"
            Cost = Worksheets("SavedSpecs").Range("ANN" & sr) + Worksheets("SavedSpecs").Range("ANP" & sr)
            Set pricingRng = Worksheets("SavedSpecs").Range("AOG" & sr & ",AOH" & sr & ",AOL" & sr)
        ElseIf l = cc Then
            plant = "CC"
            Cost = Worksheets("SavedSpecs").Range("AOU" & sr) + Worksheets("SavedSpecs").Range("AOW" & sr)
            Set pricingRng = Worksheets("SavedSpecs").Range("APN" & sr & ",APO" & sr & ",APS" & sr)
        End If
        
        Worksheets("Summary").Cells(dr, 1).Resize(1, UBound(summarySpecAr)).Value = _
        summarySpecAr
        
        Worksheets("Summary").Cells(dr, 2).Value = plant
        
        Worksheets("Summary").Cells(dr, 9).Value = Cost
        
        
        ReDim pricingAr(1 To x)
        x = 1
        
        For Each aCell In pricingRng.Cells
            pricingAr(x) = aCell.Value
            x = x + 1
        Next aCell
        
        Worksheets("Summary").Cells(dr, 10).Resize(1, UBound(pricingAr)).Value = _
        pricingAr
        
        dr = dr + 1
    
    Next l
    
Next sr

Application.ScreenUpdating = True

End Sub

I am sure there should be a way to optimize this to run faster. Does anyone have any ideas / suggestions?

[kasan]

Hi,
You work with ranges and cells, try to put your table in array and loop through array.
For some real help/code please attach sample excel file to work with, show some lines with the data and the result that should be achived.

[amros]

Thank you Kasan.

I will look into looping through an array first. A sample file is my last option as the data is sensitive. So I'd have to spend some time making those changes.