dormanino
09-10-2015, 06:41 PM
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
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