slow code with many loopings

[Valeria]

Dear experts,
I have a long code (below) with many loopings to match cell values and long
data lists, which is causing my code to be extremely slow (>1 h)

I am sure there is a better and faster way to do this... itwould be great if
you could help me!
Many thanks in advance.
Best regards

--
Valeria

Sub RawMatConsumption()

Dim FillIn As Integer, Length As Integer, LastRowSales As Integer,
LastRowBOMS As Integer, i As Integer, k As Integer, g As Integer, h As
Integer, FinishedGMID As Integer, Row1 As Integer, FirstGMIDRow As Integer,
LastGMIDRow As Integer, LastRowRWM As Integer
Dim mc As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'for some reason the xllastcell does not work correctly here so I am looping
to find the last cell

i = 1
Do
i = i + 1
Loop Until Worksheets("Sales Forecast").Cells(i, 1) = "Account
Manager"
Row1 = i + 1
i = Row1
Do
i = i + 1
Loop Until Worksheets("Sales Forecast").Cells(i, 2) = ""
LastRowSales = i

i = 1
Do
i = i + 1
Loop Until Worksheets("Raw Materials Forecast").Cells(i, 3) = ""
LastRowRWM = i

'Last Row on BOMS
Set mc = Worksheets("BOMS").Cells.SpecialCells(xlCellTypeLastCell)
LastRowBOMS = mc.Row

'to obtain a 8 digit text to be able to compare with the other data

For i = 1 To LastRowBOMS
If IsNumeric(Worksheets("BOMS").Cells(i, 1)) = True Then
Worksheets("BOMS").Cells(i, 1).NumberFormat = "@"
If Len(Worksheets("BOMS").Cells(i, 1)) <> 8 Then
If Len(Worksheets("BOMS").Cells(i, 1)) = 7 Then
Worksheets("BOMS").Cells(i, 1) = "0" &
Worksheets("BOMS").Cells(i, 1)
ElseIf Len(Worksheets("BOMS").Cells(i, 1)) = 6 Then
Worksheets("BOMS").Cells(i, 1) = "00" &
Worksheets("BOMS").Cells(i, 1)
ElseIf Len(Worksheets("BOMS").Cells(i, 1)) = 5
Then
Worksheets("BOMS").Cells(i, 1) = "000" &
Worksheets("BOMS").Cells(i, 1)
End If
End If
End If
Next i

For i = 1 To LastRowRWM
If IsNumeric(Worksheets("Raw Materials Forecast").Cells(i, 4)) = True Then
Worksheets("Raw Materials Forecast").Cells(i, 4).NumberFormat = "@"
If Len(Worksheets("Raw Materials Forecast").Cells(i, 4)) <> 8 Then
If Len(Worksheets("Raw Materials Forecast").Cells(i, 4)) = 7 Then
Worksheets("Raw Materials Forecast").Cells(i, 4) = "0" &
Worksheets("Raw Materials Forecast").Cells(i, 4)
ElseIf Len(Worksheets("Raw Materials Forecast").Cells(i, 4))
= 6 Then
Worksheets("Raw Materials Forecast").Cells(i, 4) =
"00" & Worksheets("Raw Materials Forecast").Cells(i, 4)
ElseIf Len(Worksheets("Raw Materials
Forecast").Cells(i, 4)) = 5 Then
Worksheets("Raw Materials
Forecast").Cells(i, 4) = "000" & Worksheets("Raw Materials
Forecast").Cells(i, 4)
End If
End If
End If
Next i

'Put on the left the finished product GMID (=blue)

Worksheets("BOMS").Columns(1).Insert Shift:=xlToRight


For i = 1 To LastRowBOMS

If Worksheets("BOMS").Cells(i, 2).Font.ColorIndex = 5 Then
Worksheets("BOMS").Cells(i, 1) = Worksheets("BOMS").Cells(i, 2)
Worksheets("BOMS").Cells(i, 2).ClearContents

End If

Next i

'Look for the BOM of the GMIDs

Worksheets("Sales Forecast").AutoFilterMode = False

'this is where it starts to be extremely slow....

For k = Row1 To LastRowSales

i = 1

Do
i = i + 1
Loop Until Worksheets("Sales Forecast").Cells(k, 7) =
Worksheets("BOMS").Cells(i, 1) Or i > LastRowBOMS
If i < LastRowBOMS Then
FinishedGMID = i
FirstGMIDRow = i + 4
Do
i = i + 1
Loop Until IsEmpty(Worksheets("BOMS").Cells(i,
1)) = False Or i > LastRowBOMS
If i < LastRowBOMS Then
LastGMIDRow = i - 4
Else
LastGMIDRow = i
End If
For h = FirstGMIDRow To LastGMIDRow
i = 1
Do
i = i + 1
Loop Until
Worksheets("BOMS").Cells(i, 1) = Worksheets("BOMS").Cells(h, 2) Or i >
LastRowBOMS
If i < LastRowBOMS
Then
'what to do when the
rwm is not the real raw mat? Still in progress
Else
g = 1
Do
g = g + 1
Loop
Until Worksheets("Raw Materials Forecast").Cells(g, 4) =
Worksheets("BOMS").Cells(h, 2) Or g > LastRowRWM

If g < LastRowRWM Then

Worksheets("Raw Materials Forecast").Cells(g, 7) = Worksheets("Raw
Materials Forecast").Cells(g, 7) + Worksheets("Sales Forecast").Cells(k, 17)
* 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)

Worksheets("Raw Materials Forecast").Cells(g, 8) = Worksheets("Raw
Materials Forecast").Cells(g, 8) + Worksheets("Sales Forecast").Cells(k, 19)
* 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)

Worksheets("Raw Materials Forecast").Cells(g, 9) = Worksheets("Raw
Materials Forecast").Cells(g, 9) + Worksheets("Sales Forecast").Cells(k, 21)
* 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)





Else

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 4) =
Worksheets("BOMS").Cells(h, 2)

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 5) =
Worksheets("BOMS").Cells(h, 3)

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 6) =
Worksheets("BOMS").Cells(FirstGMIDRow - 2, 4)

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 7) =
Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 7) + Worksheets("Sales
Forecast").Cells(k, 17) * 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 8) =
Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 8) + Worksheets("Sales
Forecast").Cells(k, 19) * 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)

Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 9) =
Worksheets("Raw Materials Forecast").Cells(LastRowRWM, 9) + Worksheets("Sales
Forecast").Cells(k, 21) * 1000 * Worksheets("BOMS").Cells(h, 4) /
Worksheets("BOMS").Cells(FinishedGMID + 2, 3)




Worksheets("Raw Materials Forecast").Range(Cells(LastRowRWM -
1, 1), Cells(LastRowRWM - 1, 9)).Copy

Worksheets("Raw Materials Forecast").Range(Cells(LastRowRWM,
1), Cells(LastRowRWM, 9)).PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

LastRowRWM = LastRowRWM + 1




End If



End If
Next h

End If
Next k

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[JLatham]

To find the last used cell in any column try a formula such as this:
on the current active sheet:
columnLastRow = Range("A" & Rows.Count).End(xlUp).Row
for a specific sheet in ThisWorkbook
lastRow = ThisWorkbook.Worksheets("SheetName") _
.Range("Z" & Rows.Count).End(xlUp).Row
If you prefer to use the .Cells instead of .Range you can, just use
Rows.Count for the row number, as: .Cells(Rows.Count, Col#).End(xlUp).Row

 

[Valeria]

Hi,
thank you very much for the suggestion. Will this also work when I have
blank cells in the first rows?

However, this does unfortunately not hep with my very slow macro... it is
when I start the execution of the For loop that everything becomes very slow.

Thanks,
Kind regards

 

[Per Jessen]

Hi

You can use Find rather than looping through a range to find a certain value
if present. Also you can use this :

ShA.Range("B" & Rows.Count).End(xlUp).Row

to find last row with data.


Sub RawMatConsumption()

Dim FillIn As Long, Length As Long, LastRowSales As Long, LastRowBOMS As
Long, _
i As Long, k As Long, g As Long, h As Long, FinishedGMID As Long, Row1
As Long, _
FirstGMIDRow As Long, LastGMIDRow As Long, LastRowRWM As Long
Dim mc As Range
Dim ShA As Worksheet ' Sales Forecast
Dim shB As Worksheet ' BOMS
Dim shC As Worksheet 'Raw Materials Forecast

Set ShA = Worksheets("Sales Forecast")
Set shB = Worksheets("BOMS")
Set shC = Worksheets("Raw Materials Forecast")

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Row1 = ShA.Columns(1).Find(what:="Account Manager", after:=ShA.Range("A1"),
lookat:=xlWhole, LookIn:=xlValues).Row + 1
LastRowSales = ShA.Range("B" & Rows.Count).End(xlUp).Row


'Last Row on BOMS
Set mc = Worksheets("BOMS").Cells.SpecialCells(xlCellTypeLastCell)
LastRowBOMS = mc.Row

'to obtain a 8 digit text to be able to compare with the other data

For i = 1 To LastRowBOMS
If IsNumeric(shB.Cells(i, 1)) = True Then
shB.Cells(i, 1).NumberFormat = "@"
If Len(shB.Cells(i, 1)) <> 8 Then
If Len(shB.Cells(i, 1)) = 7 Then
shB.Cells(i, 1) = "0" & shB.Cells(i, 1)
ElseIf Len(shB.Cells(i, 1)) = 6 Then
shB.Cells(i, 1) = "00" & shB.Cells(i, 1)
ElseIf Len(shB.Cells(i, 1)) = 5 Then
shB.Cells(i, 1) = "000" & shB.Cells(i, 1)
End If
End If
End If
Next i
For i = 1 To LastRowRWM
If IsNumeric(shC.Cells(i, 4)) = True Then
shC.Cells(i, 4).NumberFormat = "@"
If Len(shC.Cells(i, 4)) <> 8 Then
If Len(shC.Cells(i, 4)) = 7 Then
shC.Cells(i, 4) = "0" & shC.Cells(i, 4)
ElseIf Len(shC.Cells(i, 4)) = 6 Then
shC.Cells(i, 4) = "00" & shC.Cells(i, 4)
ElseIf Len(shC.Cells(i, 4)) = 5 Then
shC.Cells(i, 4) = "000" & shC.Cells(i, 4)
End If
End If
End If
Next i

'Put on the left the finished product GMID (=blue)

shB.Columns(1).Insert Shift:=xlToRight

For i = 1 To LastRowBOMS

If shB.Cells(i, 2).Font.ColorIndex = 5 Then
shB.Cells(i, 1) = shB.Cells(i, 2)
shB.Cells(i, 2).ClearContents
End If

Next i

'Look for the BOM of the GMIDs

ShA.AutoFilterMode = False

'this is where it starts to be extremely slow....

For k = Row1 To LastRowSales
Set f = shB.Range("A1:A" & LastRowBOMS).Find(what:=ShA.Cells(k,
7).Value, after:=shB.Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
FinishedGMID = i
FirstGMIDRow = i + 4
Do
i = i + 1
Loop Until IsEmpty(shB.Cells(i, 1)) = False Or i > LastRowBOMS
If i < LastRowBOMS Then
LastGMIDRow = i - 4
Else
LastGMIDRow = i
End If
For h = FirstGMIDRow To LastGMIDRow
i = 1
Do
i = i + 1
Loop Until shB.Cells(i, 1) = shB.Cells(h, 2) Or i > LastRowBOMS
If i < LastRowBOMS Then
'what to do when the rwm is not the real raw mat? Still in
progress
Else
g = 1
Do
g = g + 1
Loop Until shC.Cells(g, 4) = shB.Cells(h, 2) Or g >
LastRowRWM

If g < LastRowRWM Then
shC.Cells(g, 7) = shC.Cells(g, 7) + ShA.Cells(k, 17) *
1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
shC.Cells(g, 8) = shC.Cells(g, 8) + ShA.Cells(k, 19) *
1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
shC.Cells(g, 9) = shC.Cells(g, 9) + ShA.Cells(k, 21) *
1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
Else
shC.Cells(LastRowRWM, 4) = shB.Cells(h, 2)
shC.Cells(LastRowRWM, 5) = shB.Cells(h, 3)
shC.Cells(LastRowRWM, 6) = shB.Cells(FirstGMIDRow - 2,
4)
shC.Cells(LastRowRWM, 7) = shC.Cells(LastRowRWM, 7) +
ShA.Cells(k, 17) * 1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
shC.Cells(LastRowRWM, 8) = shC.Cells(LastRowRWM, 8) +
ShA.Cells(k, 19) * 1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
shC.Cells(LastRowRWM, 9) = shC.Cells(LastRowRWM, 9) +
ShA.Cells(k, 21) * 1000 * shB.Cells(h, 4) / shB.Cells(FinishedGMID + 2, 3)
shC.Range(Cells(LastRowRWM - 1, 1), Cells(LastRowRWM -
1, 9)).Copy
shC.Range(Cells(LastRowRWM, 1), Cells(LastRowRWM,
9)).PasteSpecial Paste:=xlPasteFormats

'Application.CutCopyMode = False

LastRowRWM = LastRowRWM + 1
End If
End If
Next h
End If
Next k

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
End Sub

Hopes this helps
....
Per

 

[sali]

huh, long code, just few ideas

to format number with leading zeroes, use numberformat="0000000#"

'worksheets' function searchs allways again, with each cell for worksheet,
instead use:

dim c1 as range
c1=worksheets("raw material forecast").cells(i,4)
if c1= ...

 

[sali]

huh, long code, just few ideas

dim c1 as range
c1=worksheets("raw material forecast").cells(i,4)
if c1= ...

just to correct, 'c1=' has to be 'set c1=', since c1 is object/range

 

[Don Guillett]

Long but I'll try to help. Probably MUCH better ways to find what you are
looking for.
If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.