Как подсчитать количество вхождений значения и значения соседней ячейки в диапазоне

Question

Изменить: этот вопрос был переработан, чтобы обеспечить лучшую ясность моей проблемы.

В моем вопросе два фактора.

Первый фактор: у меня есть список проверки на листе называется «Админ-лист». В этом списке находятся «Задачи». Я хотел бы сопоставить эти задачи в «списке» с задачами, содержащимися в диапазоне (rangeString), взятом из другого листа, и подсчитать количество «Вхождений» для каждого элемента.

т.е. задача 1 появляется 3 раза, задача 2 появляется 1 раз, et c et c ..

Фактор 2: для каждого элемента в списке я также хотел бы собрать количество часов, потраченных на эту задачу.

Например: Задача 1 может появляться 3 раза в 3 разных строках в пределах диапазона. В каждой строке другого столбца указаны часы, потраченные на эту конкретную задачу. Я хотел бы «Суммировать» эти часы из 3-х строк, и я хотел бы сделать это для всех «Задач».

Примечание. Диапазон является переменным и будет меняться ежедневно. Примечание. Столбцы, содержащие информацию: «F» - задачи и «K» для часов.

Моя текущая попытка просто зафиксировать «одну» задачу и связанные с ней часы:

 Dim PaintWWArray() As Variant
 Dim PHoursCnt As Long

Set srchRng = ActiveSheet.Range(rangeString)
Set rngfindValue = srchRng.find(what:="AD PAINTING W/W", Lookat:=xlPart)

'Find all the Tasks and Hours
If Not rngfindValue Is Nothing Then
   rngFirstAddress = rngfindValue.Address
    Do
        PaintWWCnt = PaintWWCnt + 1
        PHoursCnt = rngfindValue.Offset(0, 4).Value

         ReDim Preserve PaintWWArray(PHoursCnt)
         PaintWWArray(PHoursCnt) = PHoursCnt

         Set rngfindValue = srchRng.FindNext(rngfindValue)


    Loop Until rngfindValue Is Nothing Or rngfindValue.Address = rngFirstAddress

     PWWSum = Application.WorksheetFunction.Sum(PaintWWArray)
     MsgBox PWWSum

End If    

После того, как я собрал количество «Вхождений» для каждой задачи и сумму часов для каждой задачи, я хочу передать их на другой лист.

 Worksheets("Weekly Data").Range("C6").Value = PaintWWCnt
 Worksheets("Weekly Data").Range("D6").Value = PWWSum

Надеюсь, это будет яснее ...

Answer 1

Вы не сможете навсегда избавиться от необходимости каким-то образом представить свой счет. Как оказалось, есть только один действенный способ сделать это. Это: -

Все обязанности указаны в столбце A, а все добавленные обязанности - в строке 2.

Конечно, вы может использовать довольно сложный VBA для подсчета, но в Excel есть лучший способ использовать функцию рабочего листа. Чтобы настроить COUNTIF () для работы, я создал два именованных диапазона следующим образом.

["Duties"] =OFFSET(Sheet2!$C$2,0,0,COUNTA(Sheet2!$C:$C)-1)
and
["AddDuties"] =OFFSET(Duties,0,1)

Sheet2!$C$2 - это то место, где начинаются мои данные. Замените первой ячейкой первого столбца диапазона данных. COUNTA(Sheet2!$C:$C)-1 делает этот диапазон динамическим c. Функция подсчитывает, сколько записей находится в том же столбце, -1, потому что счетчик будет включать заголовок (измените, если у вас больше или меньше заголовков).

AddDuties просто определяется как «то же, что Duties ", но удален на одну колонку справа. Вы можете переместить его в другое место. Когда вы добавляете или удаляете строки в столбце Duties, AddDuties расширяется или сжимается.

Теперь формула в B3 показана ниже. Он копируется по мере необходимости. Обратите внимание на знаки $.

[B3] =COUNTIFS(Duties,$A3,AddDuties,B$2)

Вероятно, это приведет к появлению большого количества нулей. В моем примере это получилось, и они мне не понравились. Поэтому я отформатировал B3 с помощью Пользовательского формата ячеек 0;; перед копированием в другие ячейки, которые скрывают их.

Теперь этот список будет автоматически обновляться по мере того, как вы вносите записи в свои данные. Вам никогда не придется запускать код, и список всегда будет готов.

Наконец, одна рекомендация. Все ваши дополнительные обязанности, такие как «AD PAINITNG H / R», сложно правильно напечатать. Поэтому пользователь должен выбрать их из раскрывающегося списка проверки при вводе их в данные. Скорее всего, у вас уже есть список, в который попадают такие выпадающие списки. Подписи в списке подсчета должны быть взяты из одного источника. Но это создает избыточность. Лучше всего сделать список в B2: H2 счетного списка «исходным». Назовите диапазон и сделайте его динамическим c, и вам больше никогда не придется думать об этом предмете.

Answer 2

Я бы предложил использовать Словарь.

Предполагая, что вы хотите подсчитать все слова:

Dim myDict
Set myDict = CreateObject("Scripting.Dictionary")
' Go through the array
For Each addDuty In arr
    ' If you only want to count specific words, add in IF statement here
    myDict(addDuty) = myDict(addDuty) + 1
Next addDuty 

Если вы хотите подсчитывать только слова в существующем наборе, он становится немного более сложным .

Answer 3

Не совсем понятно, чего вы хотите достичь, но приведенный ниже код должен предоставить вам необходимые данные. Это очень быстро. Пожалуйста, попробуйте.

Private Sub STO_Answer()
    ' 024
    ' this procedure requires a reference to be set to
    ' Microsoft Scripting Runtime

    Dim Counter         As Scripting.Dictionary     ' store task names and their count
    Dim Arr             As Variant                  ' an array of the data in Rng
    Dim CellVal         As Variant                  ' temporary storage of each cell value
    Dim R               As Long                     ' row counter
    Dim Key             As Variant                  ' a dictionary Key

    Arr = ActiveSheet.Range("C2:D27").Value         ' change to name the sheet
                                                    ' adjust the range to suit
    Set Counter = New Scripting.Dictionary
    With Counter
        For R = 1 To UBound(Arr)                    ' loop through all rows
            AddToCounter Arr(R, 1), Counter         ' first column of cell range
            AddToCounter Arr(R, 2), Counter         ' second column of cell range
        Next R

        For Each Key In Counter.Keys
            Debug.Print Key, Counter.Item(Key)
        Next Key
    End With
End Sub

Private Sub AddToCounter(CellVal As Variant, _
                         Counter As Scripting.Dictionary)
    ' 024

    With Counter
        If .Exists(CellVal) Then
            .Item(CellVal) = .Item(CellVal) + 1
        Else
            .Add CellVal, 1
        End If
    End With
End Sub

A Словарь - это структура данных, которая содержит два связанных значения. Здесь он используется для хранения имени задачи и количества ее повторений. Убедитесь, что вы включили ссылку на Microsoft Scripting Runtime в Tools > References. Вы не указываете, существует ли какая-либо связь между задачами в первом и втором столбце. Приведенный выше код пока считает оба независимо друг от друга.

Результат печатается в окне Immediate Window. Конечно, вы можете использовать этот результат любым другим способом в своем коде. Ваш вопрос не касается ваших намерений.

Answer 4

У меня нет времени ждать разъяснений, которые я спросил ... Я подготовил фрагмент кода, исходя из предположения, что ваши строки для подсчета находятся в столбце «F: F», а значение, которое нужно рассчитать, в столбце «К: К». Результат обработки отбрасывается в последний доступный столбец активных страниц, начиная со строки 2. Если вы предпочитаете какие-то соответствующие заголовки для двух задействованных столбцов, это можно легко автоматизировать. Я использовал "Задачи и" Время ...

Он может обрабатывать столько строк 'задач', которые у вас будут в будущем.

Я прокомментировал строки кода, где я подумал вы не понимаете, что они делают:

Sub CountOccurrencesAndValues()
  Dim sh As Worksheet, rngF As Range, arrOcc As Variant, lastRow As Long, lastCol As Long
  Dim arr As Variant, arrFin As Variant, countI As Long, valH As Double, j As Long, k As Long, i As Long

  Set sh = ActiveSheet
  lastRow = sh.Range("F" & Rows.count).End(xlUp).Row
  lastCol = sh.UsedRange.Columns.count + 1
  Set rngF = sh.Range("F2:F" & lastRow) 'the range where from to extract the unique values
  arr = sh.Range("F2:K" & lastRow)      'the array to be processed

  'Extract the unique values. Use for that a not used column:
  rngF.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh.Cells(1, lastCol), Unique:=True
  'Put the unique values (sttrings) in an array:
  arrOcc = sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).value
  'Clear the temporary used array:
  sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).Clear
  ReDim arrFin(1 To UBound(arrOcc, 1), 1 To 3)

  k = 1
  'Processing the range by iteration:
  For i = 1 To UBound(arrOcc, 1)
    For j = 1 To UBound(arr, 1)
      If arr(j, 1) = arrOcc(i, 1) Then
         'count the occurrences and the value
         countI = countI + 1: valH = valH + arr(j, 6)
      End If
    Next j
    'put the data in the final array
    arrFin(k, 1) = arrOcc(i, 1): arrFin(k, 2) = countI: arrFin(k, 3) = valH
    countI = 0: valH = 0: k = k + 1
  Next i

  'Drop the data from array in the last available column:
  'sh.Cells(1, lastCol).value = "Tasks": sh.Cells(1, lastCol + 1).value = "Count": sh.Cells(1, lastCol + 2).value = "Time"
  'sh.Cells(2, lastCol).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin

  Dim ws As Worksheet
  Set ws = Worksheets("Weekly Data")
  'Drop the data from array in "Weekly Data" worksheet:
  ws.Range("C6").value = "Tasks": ws.Range("D6").value = "Count": ws.Range("E6").value = "Time"
  ws.Range("C7").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub

Answer 5

Я думаю, что лучше было бы использовать для каждого цикла, таким образом вам не придется жестко кодировать условия через IfElse. Если у вас есть значения в столбце A листа и вы хотите go через эти значения и получить их смежное значение в столбце B, вы можете использовать цикл For Each для go через каждое значение, определенное в A, чтобы получить B.

просто чтобы добавить, что касается подсчета вхождений, вы можете определить счетчик, который будет суммироваться для каждого вхождения уникального значения в столбце A.