Replace loops with arrays

[YasserKhalil]

Hello everyone
I have a code that has nested loops for columns and rows in sheet1 and for each cell check if it is greater than zero .. if the value is greater than a zero so the related data to be transferred
In sheet1 I have fixed row (1) and fixed column (1) and in between the cells to be checked
For example the cell A2 has value greater than zero so the related data would be:
-----------------
B1 in Sheet1 >> Column C in Sheet2
A2 in Sheet1 >> Column I in Sheet2
The cell itself in B2 >> Column L in Sheet2
As for Sales ID in Sheet2 Would be sequence for Customers

You can run the working code to see the expected results

Sub Test()
    Dim r1, r2, c, t, e
    
    r1 = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row
    r2 = Sheets(2).Range("a" & Rows.Count).End(xlUp).Row + 1
    Sheets(2).Range("A2:l" & r2) = ""
    Application.ScreenUpdating = False
    c = Sheets(1).Range("www1").End(xlToLeft).Column
    For t = 2 To c
        For e = 2 To r1
            If Sheets(1).Cells(e, t) > 0 Then
                r2 = Sheets(2).Range("a" & Rows.Count).End(xlUp).Row + 1
                Sheets(2).Range("a" & r2) = t - 1
                Sheets(2).Range("c" & r2) = Sheets(1).Cells(1, t).Value
                Sheets(2).Range("i" & r2) = Sheets(1).Cells(e, 1).Value
                Sheets(2).Range("l" & r2) = Sheets(1).Cells(e, t).Value
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Hope it is clear

[nilem]

Hi YasserKhalil,
try this

Sub Test22()
Dim x, i&, j&, k&
Dim SalesId(), Customer(), ItemId(), Qty()
x = Sheets("Sheet1").Range("A2").CurrentRegion.Value
ReDim SalesId(1 To UBound(x) * UBound(x, 2), 1 To 1)
Customer() = SalesId(): ItemId() = SalesId(): Qty() = SalesId()

For j = 2 To UBound(x, 2)
    For i = 2 To UBound(x)
        If x(i, j) > 0 Then
            k = k + 1
            SalesId(k, 1) = j - 1
            Customer(k, 1) = x(1, j)
            ItemId(k, 1) = x(i, 1)
            Qty(k, 1) = x(i, j)
        End If
    Next
Next
With Sheets("Sheet2")
    .UsedRange.Offset(1).ClearContents
    .Range("A2").Resize(k).Value = SalesId()
    .Range("C2").Resize(k).Value = Customer()
    .Range("I2").Resize(k).Value = ItemId()
    .Range("L2").Resize(k).Value = Qty()
End With
End Sub

[mike7952]

This should do ir

Sub abc()
 Dim a, aOutput, iCol As Long, iRow As Long, iLooper As Long
 
 With Worksheets("Sheet1")
    a = .Range("a1").CurrentRegion
 End With
 
 ReDim aOutput(1 To UBound(a) * UBound(a, 2), 1 To 12)
 
 For iCol = 2 To UBound(a, 2)
    For iRow = 2 To UBound(a)
        If a(iRow, iCol) > 0 Then
            iLooper = iLooper + 1
            aOutput(iLooper, 1) = iCol - 1
            aOutput(iLooper, 3) = a(1, iCol)
            aOutput(iLooper, 9) = a(iRow, 1)
            aOutput(iLooper, 12) = a(iRow, iCol)
            
        End If
    Next
 Next
 Sheet2.Cells(2, "A").Resize(iLooper, 12) = aOutput
End Sub

[YasserKhalil]

Mr. Nilem and Mr. Mike
Both solutions are working like charm. You are Great people
Thanks a lot for this incredible help
Best Regards