VBA Excel Подсчет определенных значений

Question

Я пытаюсь написать программу, которая будет циклически проходить по ячейкам определенного столбца (назначенного пользователем), находить новые значения в этих ячейках и подсчитывать, сколько раз найдено определенное значение. Основная проблема, с которой я сейчас сталкиваюсь, заключается в том, что она жестко запрограммирована, как показано ниже:

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) Then
        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

Здесь, если ActiveCell пуст, тогда nullInt будет увеличиваться, если ActiveCell имеет какое-то значение, то он найдет, какая из переменных имеет такое же значение, или значение ActiveCell будет назначено одной из переменных. Я создал десять переменных строго для целей тестирования, но мне нужно сделать до ста. Мне было интересно, есть ли способ завершить это быстро. Единственный способ, о котором я мог подумать, - это создать массив String и массив Int и хранить значения таким образом. Однако я не уверен, что это лучший способ сделать это.

Редактировать Эта часть предназначена специально для словарей. Скажем, есть определенный столбец под названием «Государство». Это содержит 50 североамериканских штатов. Некоторые из этих состояний повторяются, и в этом столбце содержится 800 значений. Как мне отслеживать, сколько раз (например) Техас получает удар?

Спасибо,

Джесси Смотермон

Answer 1

Вы должны быть в состоянии сделать это с помощью словаря (см. Имеет ли VBA структуру словаря? )

Этот код не был проверен, но должен дать вам начало.

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

Answer 2

Я разработал для вас код, надеюсь, это поможет. Я добавил комментарии, чтобы сделать каждый шаг понятнее для вас. Я считаю, что простая установка правильных значений в 1-м шаге может заставить вас работать.

Тем не менее, стоит понять, что делает код, чтобы помочь вам в будущем.

Надеюсь, что это соответствует вашим потребностям!

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