macro do formula caculations 100 rows at a time?

[tonywatsonhelp]

Hi Everyone,

I have a formula that i need to add to my sheet

its this "=COUNTIF($B$2:$B$60000,B2)"

now the problem I have is it needs to go into about 60,000 rows,
you can imagine this is a problem so I've developed a solution and woundered if anyone could help me do it.

Firstly let me tell you what i'm trying to do,

My sheet is called "Month2"

The formula goes into column V from row2 to last row (about 60000)
I need to do the calculation then remove the formulas so it just data,

So when I tried running a macro to insert the formula into cells V2:V & lastrow
because there are so many calculations it crashes,

So does anyone know a way to get these values into the cells quickly without it crashing?

if not can someone help me do this,

Create a macro that inserts the formula into the cells 100 rows at a time then changes the cells from formulas to values and does the next 100 and so on until we have reached the last row.

it can also be done one at a time if that's just as good.

Please help if you can

thanks

Tony

 

[Yongle]

Try this method
- amend C to the column where values are required
- amend B if there is not always a value in that column (perhaps A would be better?) - it is used to determine the last row containing values
- does it give you the correct results?
- how long does it take to run? (it can be speeded up by using arrays to manipulate the values)

Let me know. Thanks

Sub test()
Dim lastRow As Long, r As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    lastRow = Range("[COLOR=#000080]B[/COLOR]" & Rows.Count).End(xlUp).Row
        For r = 2 To lastRow
            Range("[COLOR=#ff0000]C[/COLOR]" & r).Value = Evaluate("=COUNTIF(B2:B" & lastRow & ",B" & r & ")")
        Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[tonywatsonhelp]

Hi Yongle,
Thanks very much for your help however this code take about 30 minutes to run,
any other ideas?

Thanks

Tony

 

[Yongle]

Yes - the reason that it takes so long is that 60,000 individual values are being written to the worksheet one at a time

When I get back to my PC tonight, I will amend the code to use a temporary array to hold any calculated values.
An array of values can be written to the worksheet at once.
It wll be a lot faster for you.
I will update the thread by tomorrow

 

[tonywatsonhelp]

Ok mate that's great thank you very much

 

[Yongle]

Here you go
- this should be much faster
- VBA puts the evaluated values into an array
- those values are written together to column D
- amend B and D if necessary

Sub test2()
Dim lastRow As Long, a As Long, arr As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    lastRow = Range("[COLOR=#000080]B[/COLOR]" & Rows.Count).End(xlUp).Row
    arr = Range("B2:B" & lastRow)
        For a = 1 To lastRow - 1
           arr(a, 1) = Evaluate("=COUNTIF(B2:B" & lastRow & ",B" & a + 1 & ")")
        Next
     Range("[COLOR=#ff0000]D[/COLOR]2:[COLOR=#ff0000]D[/COLOR]" & lastRow) = arr
     Erase arr
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[JackDanIce]

Hi Tony, alt suggestion, sorts the data with a helper column (supposed to help speed up), writes array contents to dictionary, incrementing existing values, then writes output to column V. It may be slower than above due to 2 loops being used but try anyway:

Sub CountMe()

Dim dic as object
Dim arr() as variant
Dim x as Long
Dim y as Long

Set dic = createobject("Scripting.Dictionary")

Application.ScreenUpdating = False

x = cells(rows.count, 2).end(xlup).row - 1
y = cells(1, columns.count).end(xltoleft).column + 1

with cells(2,y).resize(x)
   .value = cells(2,2).resize(x).value
   .Sort Key:=Cells(1,y), order1:=xlascending, header:=xlyes
   arr = .value
   .clearcontents
End With

for x = lbound(arr, 1) to ubound(arr, 1)
  dic(arr(x,1)) = 1 + iif(dic.exists(arr(x,1)), 1, 0)
next x

arr = cells(2,2).resize(ubound(arr, 1)).value

for x = lbound(arr, 1) to ubound(arr, 1)
  arr(x,1) = dic(arr(x,1))
next x

cells(2,22).resize(ubound(arr, 1)).value = arr

Application.ScreenUpdating = True

erase arr
set dic = nothing

End Sub

*Apologies for any code errors or typos, using an Apple laptop for first time and it's not Windows O/S

 

[JackDanIce]

The sort line may need header:=xlNo, With part is for cell in row 2