Macro producing not responding error

[Legacy 93538]

Hi

I have this piece of code which works perfectly and does what it should but it takes a really long time and while its running the excel crashes (comes up not responding) and it ends up with me having select Esc key and i am not sure why.

The macro i have loops through 3 columns within a table. The columns it loops through is a list of valules, the list of cell references for those values and a list of forumlas.

The macro loops through the list of forumlas and looks up the cell ref in the list fo cell ref's and once it finds it, it replaces the cell ref in the forumla with the value next to the cell ref it found in the list.

Z = WorksheetFunction.CountA(PPCWBSht.Range("J2:J10000"))
Q = WorksheetFunction.CountA(PPCWBSht.Range("L2:L10000"))
 
For Y = 1 To Q
    For X = 1 To Z
        FindRef = Range("K" & 1 + X)
        ReplRef = Range("J" & 1 + X)
        PPCWBSht.Range("D" & 1 + Y).Select
       
        Selection.Replace What:=FindRef, Replacement:=ReplRef, LookAt:=xlPart, SearchOrder:=xlByRows, _
        MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next X
        Application.StatusBar = Y
Next Y

Does anyone know hwo to rewrite this code so it does the process much quicker and without crashing?

Thanks

Jessicaseymour

 

[Jonmo1]

You might try..

1. Not Selecting The column
2. Turning off ScreenUpdating, Calculation and Events


Try

z = WorksheetFunction.CountA(PPCWBSht.Range("J2:J10000"))
Q = WorksheetFunction.CountA(PPCWBSht.Range("L2:L10000"))
 
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    PrevCalc = .Calculation
    .Calculation = xlCalculationManual
End With
For y = 1 To Q
    For x = 1 To z
        FindRef = Range("K" & 1 + x)
        ReplRef = Range("J" & 1 + x)
        Set MyRange = PPCWBSht.Range("D" & 1 + y)
        
        MyRange.Replace What:=FindRef, Replacement:=ReplRef, LookAt:=xlPart, SearchOrder:=xlByRows, _
        MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next x
        Application.StatusBar = y
Next y
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = PrevCalc
End With

Hope that helps.

 

[Legacy 93538]

Hi

Thank you for helping me!

In the with statements you added are there any variables? Also should MyRange be a string?

 

[Jonmo1]

Hi

Thank you for helping me!

In the with statements you added are there any variables? Also should MyRange be a string?

Ahh, good....you do have Option Explicit used...

Dim MyRange As Range
Dim PrevCalc As Variant

 

[Legacy 93538]

Hi

Thanks for your help.

I have run the macro again using your suggestions and it seems to crash as the screen goes blank and says Not Repsonding but when i select Esc it is seems to be running in the background.

Do you have any idas what might be causing this?

 

[Jonmo1]

Nothing that I can see..

Try removing this line

Application.StatusBar = y

 

[Legacy 93538]

Hi

Ok tried removing that line but its still really slow and still looks like its fallen over.

I could show you the whole code if that helps but it is quite large and does multiple things but in my whole code i have 4 different loops doing different things.

The first loop, loops through a cell range and makes the list of values and cell refs.
The second loop loops through the same cell range but looks at whethers its empty and if the cell is gray or yellow and creates the list of forumlas and takes data from the table the cell range is in.

The third loop takes out the $ of the cell refs

The forth loop should loop though the list of forumlas and looks up the cell ref in the list fo cell ref's and once it finds it, it replaces the cell ref in the forumla with the value next to the cell ref it found in the list.

There is also a function to determine the cells format

I have pasted the whole code in below. I have noticed it works fine when there is only 1 loop but when i add more than 1 it goes slower and looks like it has crashed.

Option Explicit
Dim stFormatStyle, stResult As String
Dim iStart, iEnd, iDigitsAfterDecimalPoint, iDecimals As Integer
Dim bIsPercentage As Boolean
Sub TESTING()
 
Dim ConvertVN, ManualVN, ManualImportVN, FindRef, ReplRef, Q, Z, CellAdd As String
Dim SConvertVN, SManualVN, X, Y As Integer
Dim StartTime As Double
Dim strFldr As String
Dim PPCWB, PPFWB As Workbook
Dim PPCWBSht, PPFWBSht As Worksheet
Dim ColN, NRow As Long
Dim Cell As Range
Dim MyRange As Range
Dim FindArray, ReplaceArray, PrevCalc As Variant

Application.ScreenUpdating = False: Application.DisplayAlerts = False
'Version number of Input Reference Form to be convert
ConvertVN = Application.InputBox("Please enter the version number of the Input Reference Form to be convert", "Convert Version Entry Box", SConvertVN)

'Is previously manually entered data to be imported
ManualVN = MsgBox("Would you like any data entered manually in previous versions to be imported", vbQuestion + vbYesNo, "Manual Version question box")
    If ManualVN = vbYes Then
        ' If yes to ManualVN then what version number to import from
        ManualImportVN = Application.InputBox("Please enter the version number of Calculations Table the data is to be imported from", "Manual Version Entry Box", SManualVN)
    End If

'Start Time
StartTime = Timer

'Set Variables
strFldr = "R:\HondaCarsEurope\Markets\Germany\PPIII\Tables"
Set PPCWB = Application.Workbooks.Add
PPCWB.Sheets.Add.Name = "CalcAPD"
Set PPCWBSht = PPCWB.Sheets("CalcAPD")
Set PPFWB = Application.Workbooks.Open(strFldr & "/" & "HDE_PPIII_MONTH_Input_Reference_form_V" & ConvertVN & ".xlsx")
Set PPFWBSht = PPFWB.Sheets("IRFORM")

'Add Headline to Calculations table
Application.StatusBar = "Add headerline to calculations table"
PPCWBSht.Activate
ColN = 1
PPCWBSht.Cells(ColN, 1).Resize(, 8).Value = Array("CalcID", "CalcDescription", "Calcname", "Calculations", _
"Department", "Category", "NumFormat", "ChartOrder")

'Define Column Arrays
FindArray = Array("AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU")
ReplaceArray = Array("F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U")

'Gather code and address list
NRow = 2
For Each Cell In PPFWBSht.Range("AF4:AU3000")
    If Cell.Value <> "" Then
            PPCWBSht.Cells(NRow, 10).Value = PPFWBSht.Range(Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Cell.Column - 26, 1) & Cell.Row).Value
            PPCWBSht.Cells(NRow, 11).Value = PPFWBSht.Range(Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Cell.Column - 26, 1) & Cell.Row).Address
            NRow = NRow + 1
            Application.StatusBar = Cell.Address
    End If
Next Cell
 
'Loop through calculations form cell range
Application.StatusBar = "Loop through calcs Form and populate calculations table"
NRow = 2
For Each Cell In PPFWBSht.Range("AF4:AU3000")
    If Cell.Value <> "" Then
        If Cell.Interior.Color = RGB(217, 217, 217) Or Cell.Interior.Color = RGB(255, 255, 0) Then
            PPCWBSht.Cells(NRow, 12).Value = "'" & Cell.Formula
            PPCWBSht.Cells(NRow, 4).Value = "'" & Cell.Formula
            PPCWBSht.Cells(NRow, 4).Select
            
            For X = 1 To UBound(ReplaceArray)
            Selection.Replace What:=FindArray(X), Replacement:=ReplaceArray(X), LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
            Next X
                       
            PPCWBSht.Cells(NRow, 1).Value = PPFWBSht.Range(Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Cell.Column - 26, 1) & Cell.Row).Value
            PPCWBSht.Cells(NRow, 2).Value = PPFWBSht.Range("E" & Cell.Row).Value
            PPCWBSht.Cells(NRow, 3).Value = PPFWBSht.Range(Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Cell.Column - 26, 1) & Cell.Row).Value
            PPCWBSht.Cells(NRow, 5).Value = PPFWBSht.Range("A" & Cell.Row).Value
            PPCWBSht.Cells(NRow, 6).Value = PPFWBSht.Range("B" & Cell.Row).Value
            PPCWBSht.Cells(NRow, 7).Value = iDecimal(Cell)
            If Cell.Interior.Color = RGB(255, 255, 0) Then
                PPCWBSht.Cells(NRow, 1).Interior.Color = RGB(255, 255, 0)
            End If
                        
            NRow = NRow + 1
                          
            Application.StatusBar = Cell.Address
            
        End If
    End If
Next Cell
'Z = WorksheetFunction.CountA(PPCWBSht.Range("J2:J10000"))
'Q = WorksheetFunction.CountA(PPCWBSht.Range("L2:L10000"))
'For X = 1 To Q
'PPCWBSht.Range("K" & 1 + X).Select
'Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
'   SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'Application.StatusBar = X
'Next X
'For Y = 1 To Q
'    For X = 1 To Z
'        FindRef = Range("K" & 1 + X)
'        ReplRef = Range("J" & 1 + X)
'        Set MyRange = PPCWBSht.Range("D" & 1 + Y)
       
'        MyRange.Replace What:=FindRef, Replacement:=ReplRef, LookAt:=xlPart, SearchOrder:=xlByRows, _
'        MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
'    Next X
'Next Y
End Sub
'Function to determine the Number format
Function iDecimal(Target As Range) As String
    'Resets the iDigitsAfterDecimalPoint variable to 0
    iDigitsAfterDecimalPoint = 0
    
    'Gets the formatting style for the cell
    stFormatStyle = Target.NumberFormat
    
    'If the format style is "general", return the default string and exit the function
    If stFormatStyle = "General" Then
        iDecimal = "%10.0f%"
        Exit Function
    End If
    
    'If the format style is "comma", find the number of digits after decimal and return the string
    If InStr(stFormatStyle, "#,##") Then
        'find the period
        iStart = InStr(stFormatStyle, ".")
        'find the ending 0
        iEnd = InStr(iStart, stFormatStyle, "_")
        'subtract the two to get the number of digits after the period
        iDigitsAfterDecimalPoint = iEnd - iStart - 1
        'return the string
        iDecimal = "%10." & iDigitsAfterDecimalPoint & "f%"
        'exit the function
        Exit Function
    End If
    
    'If the last character of the NumberFormat string is  a percentage sign, then sets a Boolean to true
    If Right(stFormatStyle, 1) = "%" Then
         bIsPercentage = True
    Else
         bIsPercentage = False
    End If
    'find the decimal point position:
    iStart = InStr(stFormatStyle, ".")
    
    'If the decimal point is 0
    If iStart = 0 Then
        iDigitsAfterDecimalPoint = 0
    Else
        iDigitsAfterDecimalPoint = Len(stFormatStyle) - iStart
    End If
    
    'If it's a percentage format with digits after period, subtract one to account for the "%" sign
    If bIsPercentage And iStart > 0 Then
        If bIsPercentage Then iDigitsAfterDecimalPoint = iDigitsAfterDecimalPoint - 1
    End If
    
    'Creating the string to be placed into the cell
    stResult = "%10." & iDigitsAfterDecimalPoint & "f%"
    If bIsPercentage Then stResult = stResult & "%"
    
    'return the string
    iDecimal = stResult
End Function

 

[Jonmo1]

Put this at the very beginning of the code..

Dim PrevCalc As Variant
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    PrevCalc = .Calculation
    .Calculation = xlCalculationManual
End With

Then the rest of your code...
Make sure you're not setting any of those back to True, or calculation to auto in the rest of your code.

Then at the very end of the code put

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = PrevCalc
End With

 

[Legacy 93538]

Hi

Thanks working better now, its still kinda slow but its not crashing anymore. So 1 down not sure there is much that can be done about the speed, there is a alot of rows in the cell ref column and the forumla column