• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 267
  • Last Modified:

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

Open in new window

SpeedData.xls
0
Cartillo
Asked:
Cartillo
  • 17
  • 16
2 Solutions
 
longtruongCommented:
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

Open in new window


I also enclosed the file here for your reference.

I hope it helps.

Long
SpeedData.xls
0
 
CartilloAuthor Commented:
Hi Long,

Thanks for the help. How we can integrate the the “Sub x()” module with your solution. Can run it simultaneously?
0
 
longtruongCommented:
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

Open in new window

Long
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
CartilloAuthor 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
 
longtruongCommented:
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

Open in new window


I hope it helps.

Long
0
 
CartilloAuthor Commented:
Hi Long,

But when type x() it shows in Red in color. How to fix this.
0
 
longtruongCommented:
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 

Open in new window


Long
0
 
CartilloAuthor 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
 
longtruongCommented:
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

[b]'-------Long added--------------
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

Open in new window


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

Regards,

Long SpeedData1.xls
0
 
longtruongCommented:
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
 
longtruongCommented:
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
 
CartilloAuthor 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
 
CartilloAuthor 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
 
longtruongCommented:
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
 
longtruongCommented:
Hello Cartillo,

Please change

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
 
CartilloAuthor 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
 
longtruongCommented:
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
 
CartilloAuthor 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
 
CartilloAuthor 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
 
CartilloAuthor 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
                    oDicTmp.Add strTmp, 1
                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

Open in new window

0
 
longtruongCommented:
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
 
CartilloAuthor Commented:
Thanks Long
0
 
longtruongCommented:
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
 
CartilloAuthor 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
 
CartilloAuthor 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
 
longtruongCommented:
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
 
CartilloAuthor Commented:
Hi,

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

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

Please assist
0
 
longtruongCommented:
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
 
CartilloAuthor 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
 
longtruongCommented:
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
 
CartilloAuthor Commented:
Hi Long,

Thanks a lot for the superb code.
0
 
longtruongCommented:
Hello Cartillo,

It's my pleasure and thanks for the points.

Regards,

Long
0
 
CartilloAuthor 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

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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