I would like to request Experts help. The attached script has been used to crosscheck data from Validation sheet and updates all unique number and dupe data at Total Sheet. The problem is the macro takes more than 3 hours to process 1,200,000,data. Is that any possible to speed up the process? Hope Experts will help me to refine or suggest with other approach to speed up the process. Attached as well the workbook for Experts perusal.

Sub Total()Dim WSV As WorksheetDim WST As WorksheetDim Rng As RangeDim RowV As LongDim ColV As LongDim RowT As LongDim ColT As LongDim MaxCol As LongDim Typee As StringDim Totall As LongDim GTotal As LongDim FirstNumber As LongDim I As LongDim J As LongSet WSV = Sheets("Validation")WSV.Copy after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)Set WSV = ActiveSheetSet Rng = WSV.Range("A1:BW65536")Set WST = Sheets("Total")RowT = 2ColT = 1GTotal = 0DoRng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftToLeftIf Rng.Cells(2, 1) = "" Then Rng.Range("2:2").EntireRow.DeleteEnd IfFirstNumber = Rng.Cells(2, 1) Totall = 0 With Rng Set C = .Find(What:=FirstNumber, LookIn:=xlValues, lookat:=xlWhole) If Not C Is Nothing Then firstAddress = C.Address firstType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5) Do Totall = Totall + 1 GTotal = GTotal + 1 Typee = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5) Set C = .FindNext(C) NewType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5) Loop While Not C Is Nothing And C.Address <> firstAddress And firstType = NewType WST.Cells(RowT, ColT) = FirstNumber WST.Cells(RowT, ColT + 1) = Typee WST.Cells(RowT, ColT + 2) = Totall DoEvents 'Clear Cells from Range Set C = .Find(What:=FirstNumber, LookIn:=xlValues, lookat:=xlWhole) If Not C Is Nothing Then firstAddress = C.Address firstType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5) Do Rng.Cells(C.row, C.Column) = "" Rng.Cells(C.row, (C.Column + 1)).Value = "" Set C = .FindNext(C) On Error Resume Next NewType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5) Loop While Not C Is Nothing And C.Address <> firstAddress And firstType = NewType Err.Clear End If ColT = ColT + 5 If ColT > 29 Then ColT = 1 RowT = RowT + 1 End If End If End WithLoop While FirstNumber <> 0Application.DisplayAlerts = FalseWSV.DeleteApplication.DisplayAlerts = TrueWST.ActivateMsgBox ("Total completed for " & GTotal & " unique items")End Sub

I suspect that just by adding the lines..
Application.ScreenUpdating = False
after the Dim statements and
Application.ScreenUpdating = True
before the msgbox statement at the end,
that just doing this will reduce the time by half.

Thanks for the feedback. If you noticed my workbook, “Total” sheet is consist of unique data from “Validation” sheet, extracted unique data from “Number” column and automatically count total “Type” data that were duped (based on first 5 alphabetic). The attached script is able to perform this, but its hung massively when its running with a huge data (you may tested with the given sample data). Therefore, if we deploys “Dictionary.Scripting” object method, we would able to reduce the number of hours that we’ve spent into half. Hope you’ll consider my request.

See how this goes. It deletes some columns from your starting sheet so make a copy first if you don't want this, and the output is in two columns.

Sub x()Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As LongSheets("Validation").ActivateOn Error Resume NextRows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeftOn Error GoTo 0vIn = Range("A1").CurrentRegion.ValueReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)Set oDic = CreateObject("Scripting.Dictionary")With oDic For i = 1 To UBound(vIn, 1) For j = 1 To UBound(vIn, 2) - 1 Step 2 If Not .Exists(vIn(i, j)) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = Left(vIn(i, j + 1), 5) .Add vIn(i, j), n End If Next j Next iEnd WithSheets("Total").Range("A1").Resize(n, 2) = vOutEnd Sub

Is that possible to copy the data evenly in other columns (have 6 columns altogether). This is because I need to crosschecked more than million data (at this moment I have 1,250,589 data). By doing so I'm able to copy all the data from Validation sheet. Also add number of data "Type" that were duped in the Validation sheet. E.g "ATZDI" duped 2x at Validation sheet. Therefore, "2" will be inputted at "Total Type" column automatically. Hope you will help me to add feature.

Sub x()Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As LongSheets("Validation").ActivateOn Error Resume NextRows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeftOn Error GoTo 0vIn = Range("A1").CurrentRegion.ValueReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)Set oDic = CreateObject("Scripting.Dictionary")With oDic For i = 2 To UBound(vIn, 1) For j = 1 To UBound(vIn, 2) - 1 Step 2 If Not .Exists(vIn(i, j)) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = Left(vIn(i, j + 1), 5) .Add vIn(i, j), n End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / 3, 0)With Sheets("Total").Range("A2") .CurrentRegion.Clear .Offset(-1).Resize(, 6).Value = Array("Number", "Type", "Number", "Type", "Number", "Type") .Resize(n, 2) = vOut .Offset(p).Resize(n - p, 2).Cut .Offset(, 2) .Offset(p, 2).Resize(n - 2 * p, 2).Cut .Offset(, 4)End WithEnd Sub

Thanks a lot. Its really super fast. Can we add the number of time the registered "Type" at Total sheet at Validation sheet. I add the sample data for better view. Hope you will consider this request. SpeedData.xls

Thanks a lot for the great help. If I intent to add more data rows, currently its limited to 3 data sets, what should I do? is that any chances the system automatically set a number of data rows based on total data availability at Validation sheet instead of adding this data rows manually?

Cartillo - do you mean extra columns, so you might want the results spread out over more columns? We could probably build this into the code and you could change when you needed to, or the user could input a figure when the macro is run.

Please help to add this function. I'm having millions of data and it's requiring more data rows to allow data spread of smoothly without any missing of data.

Cartillo - please clarify what you mean by extra rows. I don't think I understand what you are asking. Are you talking about data on the Validation sheet or the Total sheet? If the latter which of the two choices above do you prefer?

Sorry for confusion, I'm referring to Total sheet. Currently we have 3 sets of data (9 rows). Can we make it this rows being added easily based on data availability at Validation sheet. Let say,its able to create 7 sets (21 rows) or 9 rows (27 rows) automatically based on data availability at Validation sheet. Hope I am not confusing you again.

Hopefully this is it. You enter the number of sets, e.g. 3 or 7 or 9:

Sub x()Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As LongnCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)With Sheets("Validation") On Error Resume Next .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft On Error GoTo 0 vIn = .Range("A1").CurrentRegion.ValueEnd WithReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)Set oDic = CreateObject("Scripting.Dictionary")With oDic For i = 2 To UBound(vIn, 1) For j = 1 To UBound(vIn, 2) - 1 Step 2 If Not .Exists(vIn(i, j)) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = Left(vIn(i, j + 1), 5) vOut(n, 3) = 1 .Add vIn(i, j), n Else vOut(.Item(vIn(i, j)), 3) = vOut(.Item(vIn(i, j)), 3) + 1 End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / nCol, 0)With Sheets("Total") .UsedRange.Clear With .Range("A1") .Resize(, 3).Value = Array("Number", "Type", "Count") .Offset(1).Resize(n, 3) = vOut For j = 1 To nCol - 1 .Offset(, j * 4).Resize(, 3).Value = Array("Number", "Type", "Count") .Offset(p + 1, (j - 1) * 4).Resize(n - (p * j), 3).Cut .Offset(1, j * 4) Next j End WithEnd WithEnd Sub

Thanks a lot. I have tested with huge data and it shows an error as "object define error" at this line: ".Offset(1).Resize(n, 3) = vOut"

I have attached the data that I have used (in text file), can't sent it in excel format since the file is too big. I'm not sure what when wrong. Sdata.zip

If you are using xl 2003 and n is more than 65,000-odd you will run out of rows. Can you move to xl2007? Otherwise will have to come up with a workaround.

The data has been arranged in such a way that after a column reached at 65536 row, the new column will takes over the following data from Validation sheet. From my test the code failed to work after reaching 9,000 rows. What's the workaround that we can use?

I have been following the threads and due to your persistance of using Scripting.dictionnary I looked it up and looked for the diffrent options there is which are quite intressting.

Meantime I would like to point out to 1 issue:

The issue I mentioned in the previous question re the item 573510 having several Types to which you did not answer is actually repeating in the code proposed by StephanJR. Are you satissfied with compiling all the 573510 and giving you a total of 37 in your initial example or youneed a breakdown by Type that is:
573110 AZNXX 1
573510 BAZWD 3
573510 BBLOU 3
573510 BBLXF 4
573510 BBMBR 3
573510 BBMIB 3
573510 BAZKS 2
573510 BAZKR 2
573510 BAZKO 1
573510 BAZDD 1
573510 BAZCU 2
etc ...
???
As the present code and all suggested ones give you a total by number.

Sub x()Dim oDic As Object, vOut(), vIn(), vOut2()Dim i As Long, j As Long, k As Long, n As Long, p As Long, nCol As Long, r As LongnCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)With Sheets("Validation") On Error Resume Next .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft On Error GoTo 0 vIn = .Range("A1").CurrentRegion.ValueEnd WithReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)Set oDic = CreateObject("Scripting.Dictionary")With oDic For i = 1 To UBound(vIn, 1) For j = 1 To UBound(vIn, 2) - 1 Step 2 If Not .Exists(vIn(i, j)) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = Left(vIn(i, j + 1), 5) vOut(n, 3) = 1 .Add vIn(i, j), n Else vOut(.Item(vIn(i, j)), 3) = vOut(.Item(vIn(i, j)), 3) + 1 End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / nCol, 0)With Sheets("Total") .Activate .UsedRange.Clear With .Range("A1") .Resize(, 3).Value = Array("Number", "Type", "Count") For r = 1 To nCol ReDim vOut2(1 To p, 1 To 3) For i = (r - 1) * p + 1 To (r - 1) * p + p k = k + 1 For j = 1 To 3 vOut2(k, j) = vOut(i, j) Next j Next i .Offset(, (r - 1) * 4).Resize(, 3).Value = Array("Number", "Type", "Count") .Offset(1, (r - 1) * 4).Resize(p, 3) = vOut2 k = 0 Next r End WithEnd WithEnd Sub

I am impressed on how efficient and fast processing is the Scripting.Dictionary technique. I never heared of it until Cartillo mentioned it and looked around for info but could hardly find something good.

kindly suggest something where I can find more info on this.
Tks/Rgds
gowflow

I'm not sure how much of the speed increase is due to the Dictionary and how much is due to transferring data from the sheet to an array, processing the array and then writing back to the sheet. The latter also speeds things up considerably.

Definitivley array handling is the key issue. I guess dictionnary get's its advantage when you need to sort as understand it has the key capability that accesses the item rightaway when you need it. Tks your link and we never cease to learn !
gowflow

By the way the second version of the code I proposed in the previous question dealt with this issue.

StephenJR
Idea is to loop thru Numbers and also loop within the Number found for same occurence of the first 5 digits of the type to which you apply the total. So double loop

Cartillo,
I totally agree I checked the routine displayed by StephenJR and indeed its amazingly faster. Am looking at the thread that StephenJR displayed about scritiingDictionnary and its indeed a good method.

Do not want to interveen in StephenJR's routine, but if you need to have the output broken down by Type to handle the case of multiple types for one same number ie 573510 then do the following in StephenJR's code.

Replace the routine starting with
==========
With oDic
...
End With
=============

by the following routine:
=================
With oDic
For i = 1 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) And Not .Exists(Left(vIn(i, j + 1), 5)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
vOut(n, 3) = 1
.Add Left(vIn(i, j + 1), 5), n
Else
vOut(.Item(Left(vIn(i, j + 1), 5)), 3) = vOut(.Item(Left(vIn(i, j + 1), 5)), 3) + 1
End If
Next j
Next i
End With
=================

Also a minor change in the For i loop start it at 2 instead of 1 as 1 would be calculating the header which is useless !

also in your original post in Validation sheet you have 2 empty columns for every set of 3 columns so to have the data aligned you should replace
.Offset(, (r - 1) * 4).Resize(, 3).Value = Array("Number", "Type", "Count")
.Offset(1, (r - 1) * 4).Resize(p, 3) = vOut2

Managing multiple websites, servers, applications, and security on a daily basis? Join us for a webinar on May 25th to learn how to simplify administration and management of virtual hosts for IT admins, create a secure environment, and deploy code more effectively and frequently.

Workbook link problems after copying tabs to a new workbook?
David Miller (dlmille)
Intro
Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…

Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…