• Status: Solved
• Priority: Medium
• Security: Public
• Views: 271

Count number of data

Hi Experts,

I would like to request Experts help to add additional function in the attached script. The attached script able to crosscheck data at Validation sheet (column “Type”) with data at “Type” at “Total” sheet and updates number of data that were duped at Column “Count” (Total sheet).  I need help to crosscheck Data at Column “Type” (Total sheet) with data at “Data” Sheet (Table 1 to 6) and update the number of duped (frequency) of the data at “Total Data” column at “Total Sheet”. Hope Experts will help me to add this function. I have attached the workbook for Experts perusal.

``````Sub x()

Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long

nCol = 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.Value
End With

ReDim 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 i
End With

p = 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 With
End With

End Sub
``````
SpeedData.xls
0
Cartillo
• 17
• 16
2 Solutions

Commented:
Hello Cartillo,

Please try to use following function to achieve the result:

``````Function CountData(item As String, table As Range) As Integer
Dim nCount As Integer
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To table.Columns.Count
For nJ = 1 To table.Columns(nI).Rows.Count
strTmp = table.Columns(nI).Rows(nJ).Value
If (strTmp <> "") And (Left(strTmp, 5) = item) Then
nCount = nCount + 1
End If
Next nJ
Next nI
CountData = nCount
End Function
``````

I also enclosed the file here for your reference.

I hope it helps.

Long
SpeedData.xls
0

Author Commented:
Hi Long,

Thanks for the help. How we can integrate the the “Sub x()” module with your solution. Can run it simultaneously?
0

Commented:
Hello Cartillo,

Before the End Function statement in CountData function, you can use x() to call your sub.

Thing looks like as follows:

``````Function CountData...
....
x()
End Function
``````
Long
0

Author Commented:
Hi Long,

Is that possible to call your solution after Sub X? I need to run Sub X first in order for me to get the right sequence. Hope you’ll help me.
0

Commented:
Hello Cartillo,

If so, you need to place x() right after CountData function.  Thing looks like as follows:

``````Function CountData(item As String, table As Range) As Integer
x()
Dim nCount As Integer
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To table.Columns.Count
For nJ = 1 To table.Columns(nI).Rows.Count
strTmp = table.Columns(nI).Rows(nJ).Value
If (strTmp <> "") And (Left(strTmp, 5) = item) Then
nCount = nCount + 1
End If
Next nJ
Next nI
CountData = nCount
End Function
``````

I hope it helps.

Long
0

Author Commented:
Hi Long,

But when type x() it shows in Red in color. How to fix this.
0

Commented:
Hello Cartillo,

It was my bad as I always think of C++ every time I write code :-).  Please only use x instead of x(). It is because VB treats sub and function differently.  So, the correct code should be:

``````Function CountData(item As String, table As Range) As Integer
x
Dim nCount As Integer
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To table.Columns.Count
For nJ = 1 To table.Columns(nI).Rows.Count
strTmp = table.Columns(nI).Rows(nJ).Value
If (strTmp <> "") And (Left(strTmp, 5) = item) Then
nCount = nCount + 1
End If
Next nJ
Next nI
CountData = nCount
End Function
``````

Long
0

Author Commented:
Hi,

I’ve tried to get the result by running the code by clicking the “Run” button at Total Sheet, but failed. Am I missing something? I have attached the workbook for your kind perusal.

SpeedData1.xls
0

Commented:
Hello Cartillo,

Well, now your request  is clearer.  I have incorporate the CountData function into your x().  The detailed code is as follows:

``````Sub x()

Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long

nCol = 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.Value
End With

ReDim 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 i
End With

p = WorksheetFunction.RoundUp(n / nCol, 0)

With Sheets("Total")
.UsedRange.Clear
With .Range("A1")
[b].Resize(, 4).Value = Array("Number", "Type", "Count", "Total Data") 'Long modified[/b]        .Offset(1).Resize(n, 3) = vOut
For j = 1 To nCol - 1
[b].Offset(, j * 4).Resize(, 4).Value = Array("Number", "Type", "Count", "Total Data") 'Long modified[/b]            .Offset(p + 1, (j - 1) * 4).Resize(n - (p * j), 3).Cut .Offset(1, j * 4)
Next j
End With
End With

Dim nC As Long, nR As Long, nCTmp As Long, nVal As Long, strCellVal As String

For nC = 1 To nCol
For nR = 1 To p
nCTmp = (nC - 1) * 4 + 2
strCellVal = Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value

If strCellVal <> "" Then
nVal = CountData(strCellVal, Range("TABLEDATA"))
nCTmp = nCTmp + 2
Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value = nVal
End If
Next nR
Next nC[/b]

End Sub
``````

I have also enclosed the updated file here for your reference.

Regards,

Long SpeedData1.xls
0

Commented:
Hello Cartillo again,

Please remove and from the code shown in my previous response because they have been added to the code mistakenly.  However, the attached file is still good and you can use it right away.

Regards,

Long
0

Commented:
Hello Cartillo again,

Please remove [ b ] and [ / b ] from the code shown in my previous response because they have been added to the code mistakenly.  However, the attached file is still good and you can use it right away.

Regards,

Long
0

Author Commented:
Hi Long,

Thanks for the code. Have tested, but shows an error as "Method "Range" of object "Global" Failed" at this line:

Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value = nVal

How to fix this?
0

Author Commented:
Hi Long,

I noticed the code failed to work if more than 6 sets of data being assigned (it works perfectly if less than 6 data set). Can we make it this flexible?
0

Commented:
Hi Cartillo,

Please try to comment that line and add this line below:

Range("A1").Value = Chr(64 + nCTmp) & Trim(Str(nR + 1))
Exit Sub

Then, please run the code again.  After that, please copy the value of cell A1 and post it here.  Please remember to copy the exact value of A1 (including spaces) as it is very important for me to investigate.

Thanks,

Long
0

Commented:
Hello Cartillo,

strCellVal = Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value
to
strCellVal = Cells(nR + 1, nCTmp).Value

and change

Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value = nVal
to
Cells(nR + 1, nCTmp).Value = nVal

The code now should work properly.

Regards,

Long
0

Author Commented:
Hi Long,

Thanks for the help. Is that possible to speed up the Total Data count process. The code able to crosscheck 70,000 data rows for “Number” ,” Type” and “Count” within 3 minute, but it takes more  than 40 minutes to crosscheck “Total Data”. Hope you will consider this request.
0

Commented:
Hello Cartillo,

I have removed CountData function and revised your x sub routine to overcome the slow performance issue.  Could you please re-try the attached file and let me know if it meets your expectation?

Thanks,

Long
SpeedData1.xls
0

Author Commented:

Hi Long,

It's extremely fast. Thanks for the great help. I have one issue with unique data, especially on the Number type. The code only extracted unique number from Validation sheet and matched it with unique Type. Sometime I do have same Number but different "Type" data, e.g. for "573510" I have:

BAXHT
BANTA
BAZDD
BAZKS

But the code only copied "BAXHT" other data have been omitted.

How to make sure the same number with varies Type data are also copied without missed. Hope you will consider my request.
0

Author Commented:
Hi Long,

When I crosschecked big data, its failed as "Object Defined Error" at this line:
.Offset(1).Resize(n, 3) = vOut

How to fix this? I have attached the sample data that I have used (in text file). Can't send it via excel, quite big.
Sdata.zip
0

Author Commented:
Hi Long,

Manage to solve the "Object Defined Error" issue with the attached script, but not sure how to overcome same number with various Type data. Hope you will help me to make the code able to tackle this issue.
``````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 Long

nCol = 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.Value
End With

ReDim 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 i
End With

p = WorksheetFunction.RoundUp(n / nCol, 0)

With Sheets("Total")
.Activate
.UsedRange.Clear
With .Range("A1")
.Resize(, 4).Value = Array("Number", "Type", "Count", "Total 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(, 4).Value = Array("Number", "Type", "Count", "Total Count")
.Offset(1, (r - 1) * 4).Resize(p, 3) = vOut2
k = 0
Next r
End With
End With

'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")

Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer

For nI = 1 To Range("TABLEDATA").Columns.Count
For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
strTmp = Range("TABLEDATA").Columns(nI).Rows(nJ).Value
If strTmp <> "" Then
strTmp = Left(strTmp, 5)
If Not (oDicTmp.Exists(strTmp)) Then
Else
oDicTmp.item(strTmp) = oDicTmp.item(strTmp) + 1
End If
End If
Next nJ
Next nI

'Start counting process
Dim nC As Long, nR As Long, nCTmp As Long, nVal As Long, strCellVal As String

For nC = 1 To nCol
For nR = 1 To p
nCTmp = (nC - 1) * 4 + 2
strCellVal = Cells(nR + 1, nCTmp).Value
If strCellVal <> "" Then
If oDicTmp.Exists(strCellVal) Then
nVal = oDicTmp(strCellVal)
Else
nVal = 0
End If
nCTmp = nCTmp + 2
Cells(nR + 1, nCTmp).Value = nVal
End If
Next nR
Next nC

End Sub
``````
0

Commented:
Hello Cartillo,

I have tested your revised code and found out that it could not work properly.  I am still investgating your two issues and will keep you posted when I am finished.

Regards,

Long
0

Author Commented:
Thanks Long
0

Commented:
Hello Cartillo,

I have already solved the "missing data".  In regards to the "Object Defined Error" with large data, it happens due to the limitation in the number of rows and columns in all Excel versions before 2007.  There are 65536 rows and 256 columns only in all version before 2007.  When the code runs with large data, the total rows it needs to copy are over 65536 and hence, the error happens.  Starting from version 2007, the number of rows increases to 1,048,576 and the number of columns increases to 16,384.  It means the "Object Defined Error" is resolved by default with Excel 2007.  I have converted the workbook with large data to Excel 2007 format and enclosed it here for your reference.

If you have any question, please let me know.

Regards,

Long
SpeedData1---Large-Data.xlsm.zip
0

Author Commented:
Hi Long,

Thanks for fixing the error. My PC runs using excel 2007, but the PC that I’m using for tracking this data is still using 2003 (xls). Hope you’ll convert this into xls format. I’ve tried but its not working. Sorry for troubling you.
0

Author Commented:
Hi Long,

Since the problem happen because of rows, I’m planning to export data at Data and Validation sheets up to 65000 rows only. Hope with this arrangement I’m able to use .xls file.
0

Commented:
Hello Cartillo,

Please find the XLS version in the attached file.  In order to run, please remember to remove some rows so that the total rows does not exceed 65536.

If you need anything else, please let me know.

Regards,

Long
SpeedData1---Large-Data.xls.zip
0

Author Commented:
Hi,

I have tested, for some reason I’m still getting Object Define Error at this line:

.Offset(1).Resize(n, 3) = vOut

0

Commented:
Hello Cartillo,

The problem you were encountered is also related to the limitation in the number of rows.  I have put an extra IF statement in the code to check whether the number of rows exceeds 65536.  If yes, it will inform you abou the fact and stop the process nicely.

Please try and let me know if you still have any question.

Regards,

Long
SpeedData1---Large-Data.xls.zip
0

Author Commented:
Hi Long,

Thanks for fixing this error and considering my request. I’ve rerun the code and crosschecked the whole data especially those data at “Data” sheet. Its not capturing the right sum total. I have highlighted those discrepancies in Red at Total sheet. By right the Total Count should shows total number of data that was duped at the “Data” sheet but its only shows “0”. Hope you will look at this error. Apology for dragging the Question.

SpeedData1---Large-Data.zip
0

Commented:
Hello Cartillo,

The error happens because you have appended new rows to Data sheet without redefining TABLEDATA name.  For your information, in order for the code run correctly, you need to define an exact name "TABLEDATA" which covers all data that needed to check in Data sheet.  I have updated the TABLEDATA for you and the code now run properly.  Please see my updated example for more information.

Regards,

Long
SpeedData1---Large-Data.xls.zip
0

Author Commented:
Hi Long,

Thanks a lot for the superb code.
0

Commented:
Hello Cartillo,

It's my pleasure and thanks for the points.

Regards,

Long
0

Author Commented:
Hi Long,

Hope you will consider this request Q; using the same data set but need to copy only matched data.

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26879425.html
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Featured Post

• 17
• 16
Tackle projects and never again get stuck behind a technical roadblock.