Macro Keeps Hanging On 365

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,748
Office Version
  1. 365
Platform
  1. Windows
I have the macro below that I have a list on sheet 2 and I enter the column the data will be in on sheet 1 in an input box and it highlights where they are found. I used on 2010 and worked instantly, since I upgraded to 365 it hangs and sometimes doesn't complete. Can or does anything need changing for 365 please? On this occasion I had to stop it and debug and pointed to On Error Resume Next

Code:
Sub ColumnASheet2AnyColumnSheet1()
Dim x As Long, Cols As Variant, Numbers As Variant, n As Variant
  Application.ScreenUpdating = False
  Sheets("Sheet1").Activate
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
 
  Cols = Application.InputBox(prompt:="Please input columns i.e:- AB,AF,AM:AQ", Type:=2)
  If Cols = "" Or Cols = "False" Then Exit Sub
  Cols = Split(Cols, ",")
  For x = 0 To UBound(Cols)
    If InStr(Cols(x), ":") = 0 Then Cols(x) = Cols(x) & ":" & Cols(x)
    Columns(Cols(x)).TextToColumns
    Columns(Cols(x)).NumberFormat = "0"
  Next
  Cols = Join(Cols, ",")
  With Worksheets("Sheet2")
    Numbers = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
  End With
  Cells.Interior.ColorIndex = xlColorIndexNone
  For Each n In Numbers
    If Len(n) Then
      With Worksheets("Sheet1").Range(Cols)
        .Replace "*" & n & "*", "#N/A", xlWhole
        On Error Resume Next
        .SpecialCells(xlConstants, xlErrors).EntireRow.Interior.ColorIndex = 6
        On Error GoTo 0
        .Replace "#N/A", n, xlWhole
      End With
    End If
  Next
  Cells.Select
    Sheets("Sheet1").Activate
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range("C2:C611582"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
        255, 0)
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
        "A2:A611582"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:AZ611582")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.Goto Range("A1"), True
  Application.ScreenUpdating = True
 
End Sub
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I can't see anything that would be specific to Microsoft 365.
I tried to dummy up some data and that macro is doing some very strange things.
If you want to send an XL2BB sample of the data for Sheet1 and Sheet2 and a before and after image of what it normally does I can have a look.
I am in Sydney Australia so if you send it today I can have a look in my time tomorrow.
 
Upvote 0
Its an add-in to let you copy some of your spreadsheet information into this forum.
You can get the details here:- XL2BB - Excel Range to BBCode
Step 1 is often to try and reproduce the issue in this case by running the code, and you need at least some of the data to do that.

I tried to manually create some dummy data but stepping through the code did such strange things that I would like to see your data in case that is relevant.
Also to get a better understanding of what you are trying to achieve. (before and after images)
 
Upvote 0
I have no idea whether this will in fact speed up your code or not since I don't have your data to try it on but its worth a try.
Just make sure you have a copy of your original workbook and code.

I have flagged the changes with xxx and they are roughly
  • Dim statements
    • changed your 2 variant data types to ranges
    • added a rngFound dim
  • Changed your "Number =" to "Set Number ="
  • Changed your inner loop which was doing 2 replaces and setting the colour to using calling a FindAll function
  • Added the FindAll Function
    (originally sourced from StackOverflow)

VBA Code:
Option Explicit

Sub ColumnASheet2AnyColumnSheet1()
' xxx changed this code - Dim Statements xxx
Dim x As Long, Cols As Variant
Dim Numbers As Range ' Changed
Dim n As Range       ' Changed
Dim rngFound As Range


  Application.ScreenUpdating = False
  Sheets("Sheet1").Activate
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
 
  Cols = Application.InputBox(prompt:="Please input columns i.e:- AB,AF,AM:AQ", Type:=2)
  If Cols = "" Or Cols = "False" Then Exit Sub
  Cols = Split(Cols, ",")
  For x = 0 To UBound(Cols)
    If InStr(Cols(x), ":") = 0 Then Cols(x) = Cols(x) & ":" & Cols(x)
    Columns(Cols(x)).TextToColumns
    Columns(Cols(x)).NumberFormat = "0"
  Next
  Cols = Join(Cols, ",")
  With Worksheets("Sheet2")
    ' xxx changed this code - dimmed as range changed to set - xxx
    Set Numbers = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
  End With
  Cells.Interior.ColorIndex = xlColorIndexNone
  For Each n In Numbers
    If Len(n.Value) Then
    ' xxx changed this code - inside if statement - xxx
        Set rngFound = FindAll(rng:=Worksheets("Sheet1").Range(Cols), _
                                    What:="*" & n.Value & "*", _
                                    LookAt:=xlWhole)
        If Not rngFound Is Nothing Then
            rngFound.EntireRow.Interior.ColorIndex = 6
        End If
    End If
  Next
  Cells.Select
    Sheets("Sheet1").Activate
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range("C2:C611582"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
        255, 0)
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
        "A2:A611582"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:AZ611582")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.Goto Range("A1"), True
  Application.ScreenUpdating = True
 
End Sub

'https://stackoverflow.com/questions/19504858/find-all-matches-in-workbook-using-excel-vba

'Uses Range.Find to get a range of all find results within a worksheet
' Same as Find All from search dialog box
'
Function FindAll(rng As Range, What As Variant, Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, Optional SearchOrder As XlSearchOrder = xlByColumns, Optional SearchDirection As XlSearchDirection = xlNext, Optional MatchCase As Boolean = False, Optional MatchByte As Boolean = False, Optional SearchFormat As Boolean = False) As Range
    Dim SearchResult As Range
    Dim firstMatch As String
    With rng
        Set SearchResult = .Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
        If Not SearchResult Is Nothing Then
            firstMatch = SearchResult.Address
            Do
                If FindAll Is Nothing Then
                    Set FindAll = SearchResult
                Else
                    Set FindAll = Union(FindAll, SearchResult)
                End If
                Set SearchResult = .FindNext(SearchResult)
            Loop While Not SearchResult Is Nothing And SearchResult.Address <> firstMatch
        End If
    End With
End Function
 
Upvote 0
Thanks I have not had chance to send sample data. Basically what the code has to do is- I have sheet 2 with a list of data in column A, when I run the code an input box asks me what column(s) to look at on sheet 1. When the data is found on sheet 1 it highlights them.
 
Upvote 0
I figured it out eventually. The initial issue what that I had to create dummy data and to do that quickly had repeated a lot of data making not realising the code was doing lots of matches and replaces.
Also if sheet 1 had #N/As in it to start with they would get replaced with whatever the first of the matching values.

Anyway don't worry about sending me sample data, just see if the code I sent you shows any improvement in performance over what you were using.
 
Upvote 0
Thanks but that is not any better, it seems to be stuck in a loop. When it seems like its about to finish after a couple of seconds like it did before, the file flashes in the taskbar and seems to start again. It does finish after about a minute, but before it was a couple of seconds at most.
 
Upvote 0
Are your files on OneDrive or Sharepoint ?
Do you have AutoSave and/or AutoRecovery turned on ?
How many rows are on each of Sheet1 and Sheet2 ?

Since I don't have any other ideas, perhaps try turning off AutoSave and Save AutoRecover and see if that makes any difference.
(Just remember to turn them back on again if you rely on them)

1617711371846.png
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,240
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top