B
badmrfrosty8
Hi,
I've optimized some vba code you folks helped me with the other day to use
find instead of nested for loops, and added some conditional statements
specific to my application. When I run the macro, I only get partial
results; about 353 rows of them (loops through 353*6 ID's (rows in sheet 1)),
and then the macro is interrupted with an object type mismatch error on this
line.
c = ws2.Range("A2:A" & lr2).Find(What:=ID, After:=ws2.Cells(lr2, 1),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).Row
Do I just need to write an on error line? Why would it run over 2,000 times
successfully and then break? Any insights would be awesome, I've listed my
code at the bottom. Thanks again!
Sub Model()
Application.ScreenUpdating = False
Dim lr1 As Long, lr2 As Long, lr3 As Long
Dim x As Long, y As Long, constraints As Long
Dim pos As Long, ID As Variant, c As Long
'ws1: hh's
Set ws1 = ThisWorkbook.Sheets(1)
'ws2: ps's
Set ws2 = ThisWorkbook.Sheets(2)
'ws3: copy dest
Set ws3 = ThisWorkbook.Sheets(3)
'length of ps array
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'length of hh array
lr1 = ws1.Cells(Rows.Count, 2).End(xlUp).Row
'init row dest in ws3
x = 2
'how many IDs are in present row
y = 1
'look through the constraints and if the ID's match:
For Each ID In ws1.Range("B2:B" & lr1)
c = ws2.Range("A2:A" & lr2).Find(What:=ID, After:=ws2.Cells(lr2, 1),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).Row
'lc3 is in ws3; number of columns in row x
lc3 = ws3.Cells(x, Columns.Count).End(xlToLeft).Column
constraints = ws2.Cells(c, 2).Value
pos = ws1.Cells(ID.Row, 4).Value
If lc3 = 1 Then
If constraints > 1000 Then
'
If pos = 0 Or pos = 1 Then
ws2.Range("U" & c).Copy _
ws3.Cells(x, lc3)
End If
If pos = 2 Or pos = 3 Then
ws2.Range("T" & c).Copy _
ws3.Cells(x, lc3)
End If
If pos = 9 Or pos = 8 Then
ws2.Range("V" & c).Copy _
ws3.Cells(x, lc3)
End If
Else
ws2.Range("W" & c).Copy _
ws3.Cells(x, lc3)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("F" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 2 Then
ws2.Range("G" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 1 Then
ws2.Range("H" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 0 Then
ws2.Range("I" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 9 Then
ws2.Range("J" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 8 Then
ws2.Range("K" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
Else
ws2.Range("L" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("M" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 2 Then
ws2.Range("N" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 1 Then
ws2.Range("O" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 0 Then
ws2.Range("P" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 9 Then
ws2.Range("Q" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 8 Then
ws2.Range("R" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
Else
ws2.Range("S" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If constraints > 600 Then
'
If pos = 0 Or pos = 1 Or pos = 2 Then
ws2.Range("C" & c).Copy _
ws3.Cells(x, lc3 + 3)
Else
ws2.Range("D" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
Else
ws2.Range("E" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
y = y + 1
Else
If constraints > 1000 Then
'
If pos = 0 Or pos = 1 Then
ws2.Range("U" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 2 Or pos = 3 Then
ws2.Range("T" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 8 Or pos = 9 Then
ws2.Range("V" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
Else
ws2.Range("W" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("F" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 2 Then
ws2.Range("G" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 1 Then
ws2.Range("H" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 0 Then
ws2.Range("I" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 9 Then
ws2.Range("J" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 8 Then
ws2.Range("K" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
Else
ws2.Range("L" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("M" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 2 Then
ws2.Range("N" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 1 Then
ws2.Range("O" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 0 Then
ws2.Range("P" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 9 Then
ws2.Range("Q" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 8 Then
ws2.Range("R" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
Else
ws2.Range("S" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If constraints > 600 Then
'
If pos = 0 Or pos = 1 Or pos = 2 Then
ws2.Range("C" & c).Copy _
ws3.Cells(x, lc3 + 4)
Else
ws2.Range("D" & c).Copy _
ws3.Cells(x, lc3 + 4)
End If
Else
ws2.Range("E" & c).Copy _
ws3.Cells(x, lc3 + 4)
End If
y = y + 1
End If
If y = 7 Then
x = x + 1
y = 1
End If
Next
Application.ScreenUpdating = True
End Sub
I've optimized some vba code you folks helped me with the other day to use
find instead of nested for loops, and added some conditional statements
specific to my application. When I run the macro, I only get partial
results; about 353 rows of them (loops through 353*6 ID's (rows in sheet 1)),
and then the macro is interrupted with an object type mismatch error on this
line.
c = ws2.Range("A2:A" & lr2).Find(What:=ID, After:=ws2.Cells(lr2, 1),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).Row
Do I just need to write an on error line? Why would it run over 2,000 times
successfully and then break? Any insights would be awesome, I've listed my
code at the bottom. Thanks again!
Sub Model()
Application.ScreenUpdating = False
Dim lr1 As Long, lr2 As Long, lr3 As Long
Dim x As Long, y As Long, constraints As Long
Dim pos As Long, ID As Variant, c As Long
'ws1: hh's
Set ws1 = ThisWorkbook.Sheets(1)
'ws2: ps's
Set ws2 = ThisWorkbook.Sheets(2)
'ws3: copy dest
Set ws3 = ThisWorkbook.Sheets(3)
'length of ps array
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'length of hh array
lr1 = ws1.Cells(Rows.Count, 2).End(xlUp).Row
'init row dest in ws3
x = 2
'how many IDs are in present row
y = 1
'look through the constraints and if the ID's match:
For Each ID In ws1.Range("B2:B" & lr1)
c = ws2.Range("A2:A" & lr2).Find(What:=ID, After:=ws2.Cells(lr2, 1),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).Row
'lc3 is in ws3; number of columns in row x
lc3 = ws3.Cells(x, Columns.Count).End(xlToLeft).Column
constraints = ws2.Cells(c, 2).Value
pos = ws1.Cells(ID.Row, 4).Value
If lc3 = 1 Then
If constraints > 1000 Then
'
If pos = 0 Or pos = 1 Then
ws2.Range("U" & c).Copy _
ws3.Cells(x, lc3)
End If
If pos = 2 Or pos = 3 Then
ws2.Range("T" & c).Copy _
ws3.Cells(x, lc3)
End If
If pos = 9 Or pos = 8 Then
ws2.Range("V" & c).Copy _
ws3.Cells(x, lc3)
End If
Else
ws2.Range("W" & c).Copy _
ws3.Cells(x, lc3)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("F" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 2 Then
ws2.Range("G" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 1 Then
ws2.Range("H" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 0 Then
ws2.Range("I" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 9 Then
ws2.Range("J" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 8 Then
ws2.Range("K" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
Else
ws2.Range("L" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("M" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 2 Then
ws2.Range("N" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 1 Then
ws2.Range("O" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 0 Then
ws2.Range("P" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 9 Then
ws2.Range("Q" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 8 Then
ws2.Range("R" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
Else
ws2.Range("S" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If constraints > 600 Then
'
If pos = 0 Or pos = 1 Or pos = 2 Then
ws2.Range("C" & c).Copy _
ws3.Cells(x, lc3 + 3)
Else
ws2.Range("D" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
Else
ws2.Range("E" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
y = y + 1
Else
If constraints > 1000 Then
'
If pos = 0 Or pos = 1 Then
ws2.Range("U" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 2 Or pos = 3 Then
ws2.Range("T" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If pos = 8 Or pos = 9 Then
ws2.Range("V" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
Else
ws2.Range("W" & c).Copy _
ws3.Cells(x, lc3 + 1)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("F" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 2 Then
ws2.Range("G" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 1 Then
ws2.Range("H" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 0 Then
ws2.Range("I" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 9 Then
ws2.Range("J" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If pos = 8 Then
ws2.Range("K" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
Else
ws2.Range("L" & c).Copy _
ws3.Cells(x, lc3 + 2)
End If
If constraints > 300 Then
'
If pos = 3 Then
ws2.Range("M" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 2 Then
ws2.Range("N" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 1 Then
ws2.Range("O" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 0 Then
ws2.Range("P" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 9 Then
ws2.Range("Q" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If pos = 8 Then
ws2.Range("R" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
Else
ws2.Range("S" & c).Copy _
ws3.Cells(x, lc3 + 3)
End If
If constraints > 600 Then
'
If pos = 0 Or pos = 1 Or pos = 2 Then
ws2.Range("C" & c).Copy _
ws3.Cells(x, lc3 + 4)
Else
ws2.Range("D" & c).Copy _
ws3.Cells(x, lc3 + 4)
End If
Else
ws2.Range("E" & c).Copy _
ws3.Cells(x, lc3 + 4)
End If
y = y + 1
End If
If y = 7 Then
x = x + 1
y = 1
End If
Next
Application.ScreenUpdating = True
End Sub