offset in for each loop

[dormanino]

Hey Guys, trick question here...need your wisdom:

Is it possible to provoque a row/column offset in a for each range in range kind of loop?(first code)
Is it possible to use another excel tool for it in order to speed up? (see full code below)

apreciate it


For Each rng2 In ws2_range

If rng2 <> "" Or Empty Then

If Replace(rng4, " ", "") <> rng2 Then
col_offset = col_offset - 1
Else

QTvar = QTvar + 1 '//case sens

For Each rng1 In ws1_range

If ws2.Cells(rng2.Row, 1) = Replace(ws1.Cells(rng1.Row, 1), " ", "") Then

QT12mpp = QT12mpp + ws1.Cells(rng1.Row, 16).Value

End If

Next
row_offset = row_offset + 1

Set rng2 = rng2.Offset(row_offset, col_offset)
Set ws2_range = ws2_range.Offset(row_offset, col_offset)


col_offset = 0
row_offset = 0


Sub Avalia_volume_codes_variantes()


Dim ws1 As Worksheet: Set ws1 = Sheets("PPRM+PJFM")
Dim ws2 As Worksheet: Set ws2 = Sheets("Variantes para Estudo")
Dim ws3 As Worksheet: Set ws3 = Sheets("Estudo Codes")
Dim ws4 As Worksheet: Set ws4 = Sheets("Excl. codes (válidos) Actros")

Dim LR1 As Long, LC1 As Long, LZ1 As String
Dim LR2 As Long, LC2 As Long, LZ2 As String
'Dim LR3 As Long, LC3 As Long, LZ3 As String
Dim LR4 As Long, LC4 As Long, LZ4 As String

Dim row_offset As Long, col_offset As Long

Dim ws3_row As Long: ws3_row = 1

Dim QTvar As Long: QTvar = 0
Dim QT12mpp As Long: QT12mpp = 0

Dim ws1_range As Range, ws2_range As Range, ws3_range As Range, ws4_range As Range

Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
'-----------------------------------
With ws1
If WorksheetFunction.CountA(.Cells) > 0 Then
LR1 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LC1 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LZ1 = .Cells(LR1, LC1).Address
End If
End With

With ws2
If WorksheetFunction.CountA(.Cells) > 0 Then
LR2 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LC2 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LZ2 = .Cells(LR2, LC2).Address
End If
End With

'With ws3
' If WorksheetFunction.CountA(.Cells) > 0 Then
' LR3 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' LC3 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
' LZ3 = Cells(LR3, LC3).Address
' End If
'End With

With ws4
If WorksheetFunction.CountA(.Cells) > 0 Then
LR4 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LC4 = .Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LZ4 = .Cells(LR4, LC4).Address
End If
End With


Set ws1_range = ws1.Range("A2:" & "A" & LR1)


Set ws2_range = ws2.Range("J2:" & LZ2) 'todos os codes nas variantes segundo B3902V para bm escolhidos


Set ws4_range = ws4.Range("A1:" & "A" & LR4) ' todos os codes exclusivos da famímila de veículos selecionada

Application.StatusBar = False

For Each rng4 In ws4_range

If rng4 = "" Or Empty Then

Exit Sub

Else

DoEvents
Application.StatusBar = "Now doing Row #" & rng4.Row & "of #" & ws4_range.Count

For Each rng2 In ws2_range

If rng2 <> "" Or Empty Then

If Replace(rng4, " ", "") <> rng2 Then
col_offset = col_offset - 1
Else

QTvar = QTvar + 1 '//case sens

For Each rng1 In ws1_range

If ws2.Cells(rng2.Row, 1) = Replace(ws1.Cells(rng1.Row, 1), " ", "") Then

QT12mpp = QT12mpp + ws1.Cells(rng1.Row, 16).Value

End If

Next
row_offset = row_offset + 1
'Set rng2 = rng2.Offset(row_offset, col_offset)
'Set ws2_range = ws2_range.Offset(row_offset, col_offset)
' .range.Offset(row_offset, col_offset)
'End With
col_offset = 0
row_offset = 0
End If
End If
Next

With ws3
.Cells(ws3_row, 1) = rng4
.Cells(ws3_row, 2) = QTvar
.Cells(ws3_row, 3) = QT12mpp
ws3_row = ws3_row + 1
End With

End If

QTvar = 0
QT12mpp = 0

Next

End Sub

[dormanino]

Solved it using jagged arrays...not best practice i think...but since i can break the for loop (that by the way, I discovered that for-each loop is also (as range.row/range.column) read-only). Living and learning.


Sub for_each()
Dim WS1 As Worksheet: Set WS1 = Sheets("Plan1")
Dim LR1 As Long, LC1 As Long, LZ1 As String

Dim ARR1() As String
Dim ARR2() As String

Dim I As Long
Dim J As Long

With WS1
If WorksheetFunction.CountA(.Cells) > 0 Then
LR1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LZ1 = .Cells(LR1, LC1).Address
End If
End With

ReDim ARR1(1 To LR1)
ReDim ARR2(1 To LC1)

For I = LBound(ARR1) To UBound(ARR1)
For J = LBound(ARR2) To UBound(ARR2)
Sheets("plan1").Cells(1, 17) = Sheets("Plan1").Cells(I, J)
Next
Next
End Sub

[Teeroy]

Your loop appears to write each cells(I,J) value to the same location (in which case you might as well just write the last value). It's not likely that that is what you want it to do.

[dormanino]

Hi Teeroy, yes...it is intended to be like ("your code here...using i,j"). I'll change it. Thanks for the advice.


Sub for_each()
Dim WS1 As Worksheet: Set WS1 = Sheets("Plan1")
Dim LR1 As Long, LC1 As Long, LZ1 As String

Dim ARR1() As String
Dim ARR2() As String

Dim I As Long
Dim J As Long

With WS1
If WorksheetFunction.CountA(.Cells) > 0 Then
LR1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LZ1 = .Cells(LR1, LC1).Address
End If
End With

ReDim ARR1(1 To LR1)
ReDim ARR2(1 To LC1)

For I = LBound(ARR1) To UBound(ARR1)
For J = LBound(ARR2) To UBound(ARR2)
("your code here...using i,j")
Next
Next
End Sub