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

 

[Peter_SSs]

Can you post the current macro code and/or spell out exactly what it is doing? (& provide a small set of sample data & expected results?)

 

[tonywatsonhelp]

Hi Peter,

Sure,

Sub Do2018_CustomerCount()

''So first I make a list of unique names from my data.

Sheets("2018 Data").Columns("N:N").Value = Sheets("2018 Data").Columns("A:A").Value
Sheets("2018 Data").Range("N:N").RemoveDuplicates Columns:=1, Header:= _
        xlYes

'' then find the unique names last row


Lastrow1 = Sheets("2018 Data").Cells(Rows.Count, "N").End(xlUp).Row
If Lastrow1 < 2 Then
Lastrow1 = 2
End If


The one column at a time I add in a formula to count or do something then a turn that formula into values.
''' This is the bit that takes ages to run as there can be so many rows and all have to have formulas in

Sheets("2018 Data").Range("O2", "O" & Lastrow1).FormulaR1C1 = "=COUNTIFS('2017 Data'!C[-14],RC[-1])"
Sheets("2018 Data").Range("O2", "O" & Lastrow1).Value = Sheets("2018 Data").Range("O2", "O" & Lastrow1).Value
Sheets("2018 Data").Range("P2", "P" & Lastrow1).FormulaR1C1 = "=COUNTIFS('2018 Data'!C[-15],RC[-2])"
Sheets("2018 Data").Range("P2", "P" & Lastrow1).Value = Sheets("2018 Data").Range("P2", "P" & Lastrow1).Value
Sheets("2018 Data").Range("Q2", "Q" & Lastrow1).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"","""")))"
Sheets("2018 Data").Range("Q2", "Q" & Lastrow1).Value = Sheets("2018 Data").Range("Q2", "Q" & Lastrow1).Value
Sheets("2018 Data").Range("R2", "R" & Lastrow1).FormulaR1C1 = "=SUMIF(C[-17],RC[-4],C[-15])"
Sheets("2018 Data").Range("R2", "R" & Lastrow1).Value = Sheets("2018 Data").Range("R2", "R" & Lastrow1).Value
    
End Sub

 

[Legacy 421546]

VBA is single-treaded which means you cannot (easily) do what you want. Read more here:
http://www.vbforums.com/showthread....e-to-run-in-background-while-user-enters-data

 

[Peter_SSs]

Thanks for the code. Let's see if we can make a significant impact on this:

.. it takes a while to caculate every row (about 30 mins)

I don't know how many distinct values you might have in column A of each sheet (I'd like to have a ball-park figure on that if more tweaking is required). If it is very large, we may run into a problem with the Application.Transpose lines in my code and have to alter those to something else.

To test the basic idea, I'd suggest using data with no more than 50,000 rows on each sheet. Even smaller if you want to start with. If it works, then try on a full size data set and see what happens. Interested to hear how long this takes on something of reasonable size (I've only tested on small data sets so far).

Sub Current_v_Last()
  Dim dc As Object, ds As Object
  Dim aCurr As Variant, aLast As Variant, itm As Variant
  Dim i As Long, rws As Long
  Dim s As String
  
  Set dc = CreateObject("Scripting.Dictionary")
  Set ds = CreateObject("Scripting.Dictionary")
  dc.CompareMode = 1
  ds.CompareMode = 1
  With Sheets("2017 Data")
    aLast = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
  End With
  With Sheets("2018 Data")
    aCurr = Application.Index(.Cells, Evaluate("row(2:" & .Range("A" & .Rows.Count).End(xlUp).Row & ")"), Array(1, 3))
    For i = 1 To UBound(aCurr)
      s = aCurr(i, 1)
      dc(s) = dc(s) + 1
      ds(s) = ds(s) + aCurr(i, 2)
    Next i
    rws = dc.Count
    Application.ScreenUpdating = False
    .Range("N2").Resize(rws).Value = Application.Transpose(dc.Keys)
    .Range("P2").Resize(rws).Value = Application.Transpose(dc.Items)
    .Range("R2").Resize(rws).Value = Application.Transpose(ds.Items)
    For Each itm In dc.Keys()
      dc(itm) = 0
    Next itm
    For i = 1 To UBound(aLast)
      s = aLast(i, 1)
      If dc.exists(s) Then dc(s) = dc(s) + 1
    Next i
    .Range("O2").Resize(rws).Value = Application.Transpose(dc.Items)
    With .Range("Q2").Resize(rws)
      .Formula = "=IF(AND(O2=0,P2=1),""New Customer"",IF(P2>1,""Repeat Customer"",IF(AND(O2>0,P2=1),""Retained Customer"","""")))"
      .Value = .Value
    End With
    Application.ScreenUpdating = True
  End With
End Sub

 

[tonywatsonhelp]

Hi Peter,
Thank you so much for all your help,
There is unfortunatly a problem after Row 34866 i get #N/A??

It ran superfast took about 3 seconds so we are close,

To give you an idea of data size,
2017 and 2018 sheets are about 550,000 in total
the unique names is about 150,000 long

Thanks

Tony

 

[tonywatsonhelp]

I think it is just the application transpose part that is a problem from what I can tell Peter?

 

[Peter_SSs]

I think it is just the application transpose part that is a problem from what I can tell Peter?

Exactly, that's why I mentioned it before. If there is more than about 65,000 unique names the transpose will fail & you have now indicated there can be well more than that number.

See how this alternative goes for errors & time.

Sub Current_v_Last_2()
  Dim dc As Object, ds As Object
  Dim aCurr As Variant, aLast As Variant, itm As Variant, aResult As Variant
  Dim i As Long, rws As Long
  Dim s As String

  Set dc = CreateObject("Scripting.Dictionary")
  Set ds = CreateObject("Scripting.Dictionary")
  dc.CompareMode = 1
  ds.CompareMode = 1
  With Sheets("2017 Data")
    aLast = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
  End With
  With Sheets("2018 Data")
    aCurr = Application.Index(.Cells, Evaluate("row(2:" & .Range("A" & .Rows.Count).End(xlUp).Row & ")"), Array(1, 3))
    For i = 1 To UBound(aCurr)
      s = aCurr(i, 1)
      dc(s) = dc(s) + 1
      ds(s) = ds(s) + aCurr(i, 2)
    Next i
    rws = dc.Count
    ReDim aResult(1 To rws, 1 To 5)
    For i = 1 To rws
      aResult(i, 1) = dc.keys()(i - 1)
      aResult(i, 3) = dc.items()(i - 1)
      aResult(i, 5) = ds.items()(i - 1)
    Next i
    For Each itm In dc.keys()
      dc(itm) = 0
    Next itm
    For i = 1 To UBound(aLast)
      s = aLast(i, 1)
      If dc.exists(s) Then dc(s) = dc(s) + 1
    Next i
    For i = 1 To rws
      aResult(i, 2) = dc.items()(i - 1)
      Select Case True
        Case aResult(i, 2) = 0 And aResult(i, 3) = 1: aResult(i, 4) = "New Customer"
        Case aResult(i, 3) > 1: aResult(i, 4) = "Repeat Customer"
        Case aResult(i, 2) > 0 And aResult(i, 3) = 1: aResult(i, 4) = "Retained Customer"
      End Select
    Next i
    Application.ScreenUpdating = False
    .Range("N2", .Range("R" & .Rows.Count).End(xlUp).Offset(1)).ClearContents
    .Range("N2").Resize(rws, UBound(aResult, 2)).Value = aResult
    Application.ScreenUpdating = True
  End With
End Sub

 

[tonywatsonhelp]

Hi Peter,
Thank you again for all your help, the new version has been running for 15 minutes and is still going so might not be the answer,
I've had an idea thinking slightly outside the box that you might be able to help me with?

Making the list of unique Names take just a few seconds using the remove duplicates I did so maybe we could start with a macro to do this. something like:

[LEFT][COLOR=#333333][FONT=monospace]Sheets("2018 Data").Columns("N:N").Value = Sheets("2018 Data").Columns("A:A").Value
Sheets("2018 Data").Range("N:N").RemoveDuplicates Columns:=1, Header:= _
        xlYes[/FONT][/COLOR][/LEFT]

then somehow if you can take the original code or idea that you had with the first macro "

Sub Current_v_Last()"
and instead of using the raw data use the unique names list in the code (in Column N) maybe set it to just work on the first 50,000 rows as this runs super fast,and just do the formulas not the names?
and then either another macro or get it to rerun from 50001 to 100000 etc until all names have had the calculation/formulas done?

So basically beak up the data in 50,000 at a time so the application. transpose works?

I have no idea how to do this, but maybe you could help or take my idea and make it better???

Anything you can do to help would be greatly appreciated.

Thanks

Tony
​

 

[Peter_SSs]

Hmm, I had tested with 300,000 rows in each sheet, but I don't think I had enough unique values in column A. Now that I have done that, my Excel too bogs down with the code.
As yet I can't think of a better way & I don't see that using Remove Duplicates opens up any new fast avenues.

BTW, unless you spend even more time sorting the values before using Remove Duplicates, you risk it not doing the job correctly. Try this example. Then sort the data and try again.

If nothing else turns up here shortly, perhaps you could try asking in the Power BI forum