Many Loops, Slow running, Freezing Up Excel

[MarsBars]

Hello,,
I've been working on a macro to scrub a report, which comes out of a specific program, to make the data useable for basic analysis. The data is dificult to work with because the part of the record for each row is in a header row at the top of each section. The first time I wrote it, it worked fine. However, now it is being applied to much larger data sets (100K+ rows). I changed the integers to "Long" to try and take care of this, but the macro keeps running and running without finishing now. This locks up excel and requires me to forcibly close it. Sometimes, when I close it, excel doesn't close and instead throws an error. The problem being, I can't read the text box. It's blanked out. However, it highlights this line:

Cells(j + 1, 7).Value = y

Here is the rest of the code. Please let me know what you think, I'm a bit stuck.

Sub Consumption_Report()
Dim MB51 As Workbook, LCMS As Workbook
 
'Determines where the header of the report stops and the data begins
Dim a As String, B As Range
Dim Res As Variant
Dim i As Long
a = "MvT"
    With Worksheets(1)
        Set B = Worksheets(1).Range(.Cells(1, 3), .Cells(40, 3))
    End With
Res = Application.Match(a, B, 0)
If Not IsError(Res) Then
i = Res + 2
End If
'Loops through the data and adds the item number to each record.
Do While Cells(i, 2) <> "" Or Cells(i + 1, 2) <> "" Or Cells(i + 3, 2) <> ""
If Cells(i, 7) <> "" Then
    Dim x As String
        x = Cells(i, 2).Value
        Do While Cells(i + 1, 2) <> ""
        Cells(i + 1, 1).Value = x
        i = i + 1
        Loop
    Else
    i = i + 1
End If
Loop
'Loops through the data and adds the material description to each record
Dim j As Long
j = Res + 2
Do While Cells(j, 2) <> "" Or Cells(j + 1, 2) <> "" Or Cells(j + 3, 2) <> ""
If Cells(j, 2) <> "" Then
        Dim y As String
        y = Cells(j, 7).Value
        Do While Cells(j, 2) <> ""
        Cells(j + 1, 7).Value = y
        j = j + 1
        Loop
    Else
    j = j + 1
End If
Loop
'Loops through and takes care of item numbers for sets of data spanning page breaks
Dim k As Long
k = Res + 3
Do While Cells(k, 2) <> "" Or Cells(k + 1, 2) <> "" Or Cells(k + 3, 2) <> ""
If Cells(k, 2).Value = "STHU" And Cells(k, 1) = "" Then
        Dim z As String
        z = Cells((k - 7), 1).Value
        Do While Cells(k, 2) = "STHU"
        Cells(k, 1).Value = z
        k = k + 1
        Loop
    Else
    k = k + 1
End If
Loop
'Loops through and takes care of material descriptions for sets of data spanning page breaks
Dim l As Long
l = Res + 3
Do While Cells(l, 2) <> "" Or Cells(l + 1, 2) <> "" Or Cells(l + 3, 2) <> ""
If Cells(l, 2).Value = "STHU" And Cells(l, 7) = "" Then
        Dim aa As String
        aa = Cells((l - 7), 7).Value
        Do While Cells(l, 2) = "STHU"
        Cells(l, 7).Value = aa
        l = l + 1
        Loop
    Else
    l = l + 1
End If
Loop
'Deletes all lines with blank cells in column A
On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Deletes all lines with blank cells in column B
On Error Resume Next
Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Deletes all header lines from each "page" in the SAP report
Dim LastRow&, rng As Range
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("C2:C" & LastRow)
Dim StatusList As Variant, StatusItem As Variant
StatusList = Array("MvT")
For Each StatusItem In StatusList
rng.Replace What:=StatusItem, Replacement:="", LookAt:=xlWhole
Next StatusItem
On Error Resume Next
rng.SpecialCells(4).EntireRow.Delete
Err.Clear
Set rng = Nothing
 

End Sub

 

[Norie]

The main four loops seem to be looping through the same cells, and within each of those loops you are looping again.

I'm pretty sure that can be made more efficient.

Can you give use an idea of how the data is structured and what you want as the result?

Even better could you upload a sample workbook with before/after data to a file-sharing site like Box.net and post a link to it here?

 

[JoeMo]

Looks like you are placing the same value (e.g. x, ...y) in many cells in your Do loops. Why not just determine which cells get a value like x and place the x in all those cells in one shot? Your speed, even as is, will surely benefit from turning off screen updating. And if you have any formulas that need to recalculate owing to the cell changes your code is making, then you will also benefit from turning off automatic calculation while the code is running.

 

[MarsBars]

Thanks for the replies.

Unfortunately, I can't post the data due to confidentiality reasons. I tried to scrub the sensitive info out of it, but I couldn't make it both OK for publication and useful.
Sorry. I know that it would be much more useful than me trying to describe it.


The data is set up as a long list (200k+lines). At the top is a header which has information on the various parameters used to run the data. This varies in size based on which parameters are used which is why I used:

'Determines where the header of the report stops and the data begins
Dim a As String, B As Range
Dim Res As Variant
Dim i As Long
a = "MvT"
    With Worksheets(1)
        Set B = Worksheets(1).Range(.Cells(1, 3), .Cells(40, 3))
    End With
Res = Application.Match(a, B, 0)
If Not IsError(Res) Then
i = Res + 2
End If

The data itself consists of 2-row headers for each material used followed by an individual line for each time the material was used. The headers contain the material name and the material code, the lines for each use do not. This macro makes sure that each usage line has the appropriate material code and name added to it. Thus, making it far easier to analyze the data.



It also deletes a bunch of superfluous lines to clean the sheet up a bit.