开发者

VBA Excel Counting Specific Values

I'm trying to write a program that will loop through cells of a specific column (assigned by the user), find new values in those cells and count how many times a specific value is found. The main problem I'm having right now is that this is hard-coded like below:

Function findValues() As Long
For iRow = 2 To g_totalRow
    If (ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text = "") Then
        nullInt = nullInt + 1
    ElseIf (someValue1 = "" Or someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt1 = someInt1 + 1
    ElseIf (someValue2 = "" Or someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt2 = someInt2 + 1
    ElseIf (someValue3 = "" Or someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Th开发者_JS百科en
        someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt3 = someInt3 + 1
    ElseIf (someValue4 = "" Or someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt4 = someInt4 + 1
    ElseIf (someValue5 = "" Or someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt5 = someInt5 + 1
    ElseIf (someValue6 = "" Or someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt6 = someInt6 + 1
    ElseIf (someValue7 = "" Or someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt7 = someInt7 + 1
    ElseIf (someValue8 = "" Or someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt8 = someInt8 + 1
    ElseIf (someValue9 = "" Or someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt9 = someInt9 + 1
    ElseIf (someValue10 = "" Or someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
        someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
        someInt10 = someInt10 + 1
    End If
Next iRow
End Function

Here, if the ActiveCell is blank then the nullInt will get incremented, if the ActiveCell has some value then it'll find which of the variables has that same value or the ActiveCell value will be assigned to one of the variables. I created ten variables strictly for testing purposes but I need to make up to one hundred. I was wondering if there was a way to complete this quickly. The only way I could think of was to create a String array and an Int array and store the values that way. However I'm not sure if this is the best way to get this done.

Edit This portion is directed specifically to dictionaries. Say there is a specific column titled "State". This contains the 50 North American states. Some of these states are repeated and there is a total of 800 values in this column. How do I keep track of how many times (for example) Texas gets hit?

Thank you,

Jesse Smothermon


You should be able to do this with a Dictionary (see Does VBA have Dictionary Structure?)

This code hasn't been tested but should give you a start.

Function findValues() As Scripting.Dictionary
Dim cellValue
Dim dict As New Scripting.Dictionary

For iRow = 2 To g_totalRow

    cellValue = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
    If dict.Exists(cellValue) Then
        dict.Item(cellValue) = dict.Item(cellValue) + 1
    Else
        dict.Item(cellValue) = 1
    End If
Next iRow

Set findValues = dict

End Function


Sub displayValues(dict As Scripting.Dictionary)
    Dim i
    Dim value
    Dim valueCount

    For i = 1 To dict.count
        valueCount = dict.Items(i)
        value = dict.Keys(i)

        ActiveWorkbook.Sheets(sheetName).Cells(i, 3).Text = value
        ActiveWorkbook.Sheets(sheetName).Cells(i, 4).Text = valueCount
    Next i

End Sub

Sub RunAndDisplay()
    Dim dict

    Set dict = findValues

    displayValues dict

End Sub


I've drafted a code for you, hope it helps. I added comments to make each step clearer for you. I believe that simply setting the proper values in the 1st step might make it work for you.

Still, would worth to understand what the code does to help you in the future.

Hope it fits your needs!

Option Explicit

Sub compareValues()

    Dim oSource As Excel.Range
    Dim oColumn As Excel.Range
    Dim oCell As Excel.Range
    Dim sBookName As String
    Dim sSheetCompare As String
    Dim sSheetSource As String
    Dim sUserCol As String
    Dim sOutputCol As String
    Dim sFirstCell As String
    Dim vDicItem As Variant
    Dim sKey As String
    Dim iCount As Integer
    Dim sOutput As String
    Dim oDic As Scripting.Dictionary

    '1st - Define your source for somevalues and for the data to be compared
    sBookName = "Book1"
    sSheetCompare = "Sheet1"
    sSheetSource = "Sheet2"
    sFirstCell = "A1"
    sOutputCol = "C"

    '2nd - Define the 'somevalues' origin value; other values will be taken
    '   from the rows below the original value (i.e., we'll take our
    '   somevalues starting from sSheetSource.sFirstCell and moving to the
    '   next row until the next row is empty
    Set oSource = Workbooks(sBookName).Sheets(sSheetSource).Range(sFirstCell)

    '3rd - Populate our dictionary with the values beggining in the sFirstCell
    populateDic oSource, oDic

    'At this stage, we have all somevalues in our dictionary; to check if the
    '   valuesare as expected, uncomment the code below, that will print into
    '   immediate window (ctrl+G) the values in the dictionary

    For Each vDicItem In oDic

        Debug.Print vDicItem

    Next vDicItem

    '4th - ask the user for the column he wants to use; Use single letters.
    '   E.g.: A
    sUserCol = InputBox("Enter the column the data will be compared")

    '5th - scan the column given by the user for the values in the dictionary
    Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sUserCol)

    '6th - Now, we scan every cell in the column
    For Each oCell In oColumn.Cells

        sKey = oCell.Value

        '7th - Test the special case when the cell is empty
        If sKey = "" Then oDic("Empty") = oDic("Empty") + 1

        '8th - Test if the key value exists in the dictionary; if so, add it
        If oDic.Exists(sKey) Then oDic(sKey) = oDic(sKey) + 1

        '9th - Added to exit the for when row reaches 1000.
        If oCell.Row = 1000 Then Exit For

    Next oCell

    '10th - Now, we print back the counters we found, only for sample purposes
    '   From now on, is up to you how to use the dictionary :)

    iCount = 1

    Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sOutputCol)
    Set oCell = oColumn.Cells(1, 1)

    For Each vDicItem In oDic

        If oDic(vDicItem) > 0 Then

            oCell.Value = vDicItem
            oCell.Offset(0, 1).Value = oDic(vDicItem)

            Set oCell = oCell.Offset(1, 0)

        End If

    Next vDicItem

End Sub

Sub populateDic(ByRef oSource As Excel.Range, _
    ByRef oDic As Scripting.Dictionary)



    'Ideally we'd test if it's created. Let's just set it for code simplicity
    Set oDic = New Scripting.Dictionary

    'Let's add an 'empty' counter for the empty cells
    oDic.Add "Empty", 0

    While Len(oSource.Value) > 0

        'If the data is not added into somevalues dictionary of values, we add
        If Not oDic.Exists(oSource.Value) Then oDic.Add CStr(oSource.Value), 0

        'Move our cell to the next row
        Set oSource = oSource.Offset(1, 0)

    Wend

End Sub
0

上一篇:

下一篇:

精彩评论

暂无评论...
验证码 换一张
取 消

最新问答

问答排行榜