Is it possible to have a macro run in the background without disturbing the user

[tonywatsonhelp]

Hi Everyone,

I have a more general question then normal,

Let me explain, I have a macro the counts the number of times a persons name is in my data,

Current I have over 200,000 names so you can imagine it takes a while to caculate every row (about 30 mins)

I have tried a few ways to speed this up but basically its going to take this long whatever I do.

So I was wondering.

Is there a way I can get this macro to run quietly in the background without disturbing me or interrupting my work?

the perfect solution would be something like I open the document, start using it and it tells me when the sheet that's updating is available>

any ideas suggestions or tricks would be a great help.

Thanks

Tony

 

[tonywatsonhelp]

Hi Peter,
I've been playing around with your original code and it works so great I have decided to use it.
this might sound crazy but heres what I'm going to do.

First I set up the names,
I make a list of unique names (I've been using this method for a long time and it works great and I can always get it to do what I need)
then I'm splitting the list up into Rows of 50,000

so I might for example have 6 rows spaced apart, then I run the macro on the rows of 50,000

I've done this manually and the 6 macros took less than a minute to run so I think i'm in business.

I could not have done this without your help and know its not a normal solution but it does what I want so that's great.
Thank you very much for all your help.

Tony

 

[Peter_SSs]

I'm not seeing how that can work, but then I am not all that familiar with your data. Can you post the code so I can test with it?

 

[tonywatsonhelp]

Hi Peter,
After hours of trying I can't get it to work,
I'm now totally stuck so don't know what to try next.
Thank you some much for all your help
Tony

 

[Peter_SSs]

I have thought some more about your suggested approach & have come up with the code below. For sample data of 300,000 rows in each sheet, of which there are about 190,000 unique values in column A of the 2018 sheet, the code is running in about 10-15 seconds for me. If you can get similar results then that at least is a big saving on 30 minutes.

Instead of processing in fixed blocks of 50,000 unique items, I have experimented with different sized blocks via the 'Const' line in the code and for me the fastest results were using a block size of around 20,000 to 30,000. Remember that block size shouldn't go above about 65,000 though. I have left the timer lines of code in for you to test. Timing results appear in the Immediate window pane of the vba window. You can remove those 3 lines when satisfied with any testing.

Sub Current_v_Last_3()
  Dim dc As Object, ds As Object, dl As Object
  Dim aCurr As Variant, aLast As Variant, aUnique As Variant
  Dim i As Long, rws As Long, lr As Long, r As Long, k As Long
  Dim s As String
  
  Dim t As Single '***********************
  t = Timer       '***********************
  
  Const Block As Long = 30000   '<- Try experimenting with different values here

  Set dc = CreateObject("Scripting.Dictionary")
  Set ds = CreateObject("Scripting.Dictionary")
  Set dl = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  With Sheets("2017 Data")
    aLast = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
  End With
  With Sheets("2018 Data")
    Intersect(.UsedRange, .Columns("N:R")).ClearContents
    With .Range("N1:N" & .Range("A" & .Rows.Count).End(xlUp).Row)
      .Value = .Offset(, -13).Value
      .Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlYes
      .RemoveDuplicates Columns:=1, Header:=xlYes
      lr = .Cells(.Cells.Count + 1).End(xlUp).Row
    End With
    aUnique = .Range("N2:N" & lr).Value
    rws = UBound(aUnique)
    k = 2
    aCurr = Application.Index(.Cells, Evaluate("row(2:" & .Range("A" & .Rows.Count).End(xlUp).Row & ")"), Array(1, 3))
    For r = 1 To rws Step Block
      dc.RemoveAll
      ds.RemoveAll
      dl.RemoveAll
      For i = 0 To Block - 1
        If r + i <= rws Then
          s = aUnique(r + i, 1)
          dc(s) = 0
          ds(s) = 0
          dl(s) = 0
        End If
      Next i
      For i = 1 To UBound(aCurr)
        s = aCurr(i, 1)
        If dc.exists(s) Then
          dc(s) = dc(s) + 1
          ds(s) = ds(s) + aCurr(i, 2)
        End If
      Next i
      For i = 1 To UBound(aLast)
        s = aLast(i, 1)
        If dl.exists(s) Then dl(s) = dl(s) + 1
      Next i
      With .Range("O" & k).Resize(dc.Count)
        .Value = Application.Transpose(dl.Items)
        .Offset(, 1).Value = Application.Transpose(dc.Items)
        .Offset(, 3).Value = Application.Transpose(ds.Items)
        With .Offset(, 2)
          .FormulaR1C1 = "=IF(AND(RC[-2]=0,RC[-1]=1),""New Customer"",IF(RC[-1]>1,""Repeat Customer"",IF(AND(RC[-2]>0,RC[-1]=1),""Retained Customer"","""")))"
          .Value = .Value
        End With
      End With
      k = k + Block
    Next r
  End With
  Application.ScreenUpdating = True
  Debug.Print "Block size = " & Block & vbTab & "Time = " & Format(Timer - t, "0.000 secs") '***********************
End Sub

 

[tonywatsonhelp]

Hi Peter,
Wow, this is perfect, so glad my Idea was able to be used as I tried but had no idea what I was doing LOL
Thank you very much.

If I hit a problem I'll let you know but runs in 10-15 seconds which is perfect

Thank very much for all your help, I appreciate it very much.

Tony

 

[Peter_SSs]

.. runs in 10-15 seconds which is perfect

Yes, not sure we can do much better, but a great improvement on 30 minutes.