Macro Freezes PC

[Dazzawm]

A friend has very kindly given me a Macro that does what I need it to do. The problem is after it has been running a few minutes Excel stops responding and freezes and I have to ctrl+alt+del. The macro is a very small code but has to look through a lot of data. What can be done to speed macros up?

 

[VoG]

Hi. Can you post the code.

 

[Dazzawm]

Sub MatchAndUpdate()
R = Sheets("Source").Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To R
q = Sheets("Source").Cells(a, 12).Text
RR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For aa = 1 To RR
If Sheets("Sheet1").Cells(aa, 12).Text = q Then
x = Sheets("Sheet1").Cells(aa, 9).Text
xx = Sheets("Source").Cells(a, 9).Text
If x = xx Then GoTo nextaa
If Mid$(xx, 1, Len(x)) = x Then
Sheets("Sheet1").Cells(aa, 9) = Sheets("Source").Cells(a, 9)
Sheets("Sheet1").Cells(aa, 9).Interior.ColorIndex = 6
End If
End If
nextaa:
Next aa
Next a
End Sub

I guess by reading the code you can see what it has to do but this link tells you:-

http://www.mrexcel.com/forum/showthread.php?t=531235

 

[VoG]

Try

Sub MatchAndUpdate()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
R = Sheets("Source").Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To R
    q = Sheets("Source").Cells(a, 12).Text
    RR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For aa = 1 To RR
        If Sheets("Sheet1").Cells(aa, 12).Text = q Then
            x = Sheets("Sheet1").Cells(aa, 9).Text
            xx = Sheets("Source").Cells(a, 9).Text
        If x = xx Then GoTo nextaa
        If Mid$(xx, 1, Len(x)) = x Then
            Sheets("Sheet1").Cells(aa, 9) = Sheets("Source").Cells(a, 9)
            Sheets("Sheet1").Cells(aa, 9).Interior.ColorIndex = 6
        End If
        End If
nextaa:
    Next aa
Next a
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

When posting code please use code tags:


[code]
your code here
[/code]

 

[Dazzawm]

Still freezing I'm afraid, how do I post codes with tags also.

 

[VoG]

I don't see why that should freeze but maybe if you have event code

Sub MatchAndUpdate()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
R = Sheets("Source").Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To R
    q = Sheets("Source").Cells(a, 12).Text
    RR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For aa = 1 To RR
        If Sheets("Sheet1").Cells(aa, 12).Text = q Then
            x = Sheets("Sheet1").Cells(aa, 9).Text
            xx = Sheets("Source").Cells(a, 9).Text
        If x = xx Then GoTo nextaa
        If Mid$(xx, 1, Len(x)) = x Then
            Sheets("Sheet1").Cells(aa, 9) = Sheets("Source").Cells(a, 9)
            Sheets("Sheet1").Cells(aa, 9).Interior.ColorIndex = 6
        End If
        End If
nextaa:
    Next aa
Next a
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With
End Sub

To use code tags (which preserves the indenting}



type [code]

paste in the code

type [/code]

 

[Dazzawm]

Still the same, when I ctrl+alt+del a error box comes up briefly saying

Run-time error '-2147417848 (80010108)':

Method 'Text' of object 'Range' failed

end, debug etc..

 

[VoG]

Click Debug. Which line of code is highlighted? Are there error values like #N/A in the range?

 

[Dazzawm]

I think it was

If Sheets("Sheet1").Cells(aa, 12).Text = q Then

that was highlighted yellow. It went to quick!

 

[VoG]

Maybe like this. You might need additional checks for errors

Sub MatchAndUpdate()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
R = Sheets("Source").Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To R
    q = Sheets("Source").Cells(a, 12).Text
    RR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For aa = 1 To RR
        If Not IsError(Sheets("Sheet1").Cells(aa, 12)) Then
            If Sheets("Sheet1").Cells(aa, 12).Text = q Then
                x = Sheets("Sheet1").Cells(aa, 9).Text
                xx = Sheets("Source").Cells(a, 9).Text
            If x = xx Then GoTo nextaa
            If Mid$(xx, 1, Len(x)) = x Then
                Sheets("Sheet1").Cells(aa, 9) = Sheets("Source").Cells(a, 9)
                Sheets("Sheet1").Cells(aa, 9).Interior.ColorIndex = 6
            End If
            End If
        End If
nextaa:
    Next aa
Next a
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With
End Sub