Как использовать count в VBA для подсчета количества действий, связанных с указанным номером?

Question

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

Цель этого состоит в том, чтобы вставить правильное количество необходимых строк (что правильно, но количество строк в обратном направлении), а затем заполнить эти новые строки информацией из другого листа в цикле. Информация находится путем перекрестной ссылки на номер активности, введенный в столбце A подзадач. Как только совпадение найдено, идеальной ситуацией будет копирование содержимого ячейки C слева от совпадения и вставка в новые вставленные столбцы. любая помощь будет оценена, так как это сводит меня с ума!

Sub createActivity()

    Application.ScreenUpdating = False

    Dim deliveryWs As Worksheet

    Set deliveryWs = ActiveWorkbook.Worksheets("Delivery and acceptance sheet")

    ' Find start and end positions of activity table
    activityStart = valuePos(deliveryWs, "A:A", "Activity")
    activityEnd = valuePos(deliveryWs, "A:A", "Supplier Technical Focal point") - 1

    ' Insert row at the last position of Activity table
    deliveryWs.Range("A" + CStr(activityEnd)).EntireRow.Insert

    ' Copy formatting from line above
    Call copyFormattingAbove(deliveryWs, "A" + CStr(activityEnd))

    ' Create activity number
    deliveryWs.Range("A" + CStr(activityEnd)) = deliveryWs.Range("A" + CStr(activityEnd - 1)) + 1

    ' Find start and end positions of deliverables table
    deliverablesStart = valuePos(deliveryWs, "C:G", "Outputs / Deliverables")
    deliverablesEnd = valuePos(deliveryWs, "A:G", "Tools / constraints")

    ' Insert row at the last position of Deliverables table
    deliveryWs.Range("A" + CStr(deliverablesEnd)).EntireRow.Insert

    ' Copy formatting from line above
    Call copyFormattingAbove(deliveryWs, "A" + CStr(deliverablesEnd))

    ' Numerate row according to activity
    deliveryWs.Range("A" + CStr(deliverablesEnd)) = deliveryWs.Range("A" + CStr(activityEnd))
    deliveryWs.Range("B" + CStr(deliverablesEnd)) = deliveryWs.Range("A" + CStr(activityEnd)) + 0.1

    ' Create new line for deliverable on Delivery and Validation for Invoicing table
    Call updateInvoicingTable(deliveryWs, deliverablesEnd, deliverablesEnd - deliverablesStart)

    ' Create formula for activity Workload
    deliveryWs.Range("L" + CStr(activityEnd)) = "=SUM(N" + CStr(deliverablesEnd) + ":N" + CStr(deliverablesEnd) + ")"

    Application.ScreenUpdating = True

End Sub

Sub createDeliverable()

    Application.ScreenUpdating = False

    Dim activityNumber As Variant

    Dim deliveryWs As Worksheet

    Set deliveryWs = ActiveWorkbook.Worksheets("Delivery and acceptance sheet")

    activityNumber = InputBox("Input Activity number")
    If activityNumber = "" Then Exit Sub

     'Count number of rows in column A with user specified number in (Activity Number)

    ' Find start and end positions of deliverables table
    deliverablesStart = valuePos(deliveryWs, "C:G", "Outputs / Deliverables")
    deliverablesEnd = valuePos(deliveryWs, "A:G", "Tools / constraints")

    ' Find start and end positions of activity within Deliverables table
    delivActivStart = valuePos(deliveryWs, "A" + CStr(deliverablesStart) + ":A" + CStr(deliverablesEnd), "# " + CStr(activityNumber))
    delivActivEnd = valuePos(deliveryWs, "A" + CStr(deliverablesStart) + ":A" + CStr(deliverablesEnd), "# " + CStr(activityNumber + 1))
    If delivActivEnd = -1 Then
        delivActivEnd = valuePos(deliveryWs, "A:G", "Tools / constraints")
    End If

    'Search through column in sub task sheet to identify matches with the activity number inputted
    Dim iVal As Integer
    Dim SubTaskWs As Worksheet

   Set SubTaskWs = ActiveWorkbook.Worksheets("Sub tasks")

   iVal = Application.WorksheetFunction.CountIf(SubTaskWs.Range("A:A"), activityNumber)

    'Loop to identify number of rows and insert them inot spreadhseet in exisitng format
    For i = 1 To (iVal - 1)

        'Insert row at the last position of Activity table
        deliveryWs.Range("A" + CStr(delivActivEnd)).EntireRow.Insert

        ' Copy formatting from line above
        Call copyFormattingAbove(deliveryWs, "A" + CStr(delivActivEnd))

        ' Number Deliverable
        deliveryNum = deliveryWs.Range("B" + CStr(delivActivEnd - 1)) + (0.1 * i)
        deliveryWs.Range("B" + CStr(delivActivEnd)) = deliveryNum

        ' Update sum of workload for activity
        Call updateActivityWorkload(deliveryWs, activityNumber, delivActivStart, delivActivEnd)

        ' Create new line for deliverable on Delivery and Validation for Invoicing table
        Call updateInvoicingTable(deliveryWs, delivActivEnd, delivActivEnd - deliverablesStart)

    Next i
End Sub



Private Function valuePos(ws, col, value)

    Dim rng1 As Range

    With ws.Range(col)
        Set rng1 = .Find(value, LookIn:=xlValues, After:=.Cells(.Cells.Count), LookAt:=xlWhole)
    End With

    If rng1 Is Nothing Then
        valuePos = -1
    Else
        valuePos = rng1.Row
    End If

End Function

Private Sub copyFormattingAbove(ws, Cell)

    ws.Range(Cell).Offset(-1, 0).EntireRow.Copy
    ws.Range(Cell).Offset(0, 0).EntireRow.PasteSpecial xlPasteFormats

End Sub

Private Sub updateActivityWorkload(ws, activityNumber, delivActivStart, delivActivEnd)

    ' Find start and end positions of activity table
    activityStart = valuePos(ws, "A:A", "Activity")
    activityEnd = valuePos(ws, "A:A", "Supplier Technical Focal point") - 1

    ' Find activity row within Activity table
    activityPos = valuePos(ws, "A" + CStr(activityStart) + ":A" + CStr(activityEnd), "# " + CStr(activityNumber))

    ' Update function
    ws.Range("L" + CStr(activityPos)) = "=SUM(N" + CStr(delivActivStart) + ":O" + CStr(delivActivEnd) + ")"

End Sub

Private Sub updateInvoicingTable(ws, delivActivEnd, delivPos)

    ' Find start and end positions of invoicing table
    invoicingStart = valuePos(ws, "A:D", "Outputs / Deliverables")
    invoicingEnd = valuePos(ws, "A" + CStr(invoicingStart) + ":A" + CStr(300000), "") ' Will only work until row 300000

    ' Insert row for the new deliverable
    ws.Range("A" + CStr(invoicingStart + delivPos)).EntireRow.Insert

    ' Copy formatting from line above
    Call copyFormattingAbove(ws, "A" + CStr(invoicingStart + delivPos))

    ws.Range("A" + CStr(invoicingStart + delivPos)) = "=$B" + CStr(delivActivEnd)

    ws.Range("B" + CStr(invoicingStart + delivPos)) = "=$C" + CStr(delivActivEnd)
End Sub

введите описание изображения здесь

Answer 1

При подсчете количества действий на вашем листе активности, вам нужно только подсчитать, сколько раз ваш пользовательский номер встречается в диапазоне ячеек, содержащих только цифры? Если это так, то эта дурацкая версия может легко справиться с задачей, если ее адаптировать и добавить в код:

Sub addin_values()
Dim Lastrow As Integer, i As Integer
Dim activityNumber As String
Dim i As integer: i = 1
Dim hit As String
Dim coppy As New Collection
activityNumber = InputBox("Input Activity Number")
Lastrow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
For Each cel In Sheets("Sheet2").Range("A1:A" & Lastrow)    
If cel.Value Like "*" & activityNumber & "*" Then
    Sheets("Sheet1").Range("A" & 2 + i).EntireRow.Insert
    Sheets("Sheet1").Range("A" & 2 + i).Value    
    i = i+1
End If
Next cel
For i = 1 To coppy.Count
 = coppy(i)
Next i
End Sub

Если в ячейках содержится больше информации, чем просто номер действия, адаптируйтесь так:

Dim activityNumber As String 'replace dim of activityNumber with this
activityNumber = "*" & activityNumber & "*" 'add in after the inputbox

РЕДАКТИРОВАТЬ согласно обновленному вопросу, значения смещения каждого попадания должны быть скопированы. Это немного сложнее, чем просто подсчитать количество попаданий. Поэтому я решил добавить цикл, который ищет все ячейки в электронной таблице, и добавить смещение всех совпадений в коллекцию. Затем на листе 1 другой цикл будет вставлять новую строку для каждого попадания в коллекции и после значения.

Sub addin_values()
Dim Lastrow As Integer, i As Integer
Dim activityNumber As String
Dim cel As Range
Dim hit As String
Dim coppy As New Collection
activityNumber = InputBox("Input Activity Number")
Lastrow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
For Each cel In Sheets("Sheet2").Range("A1:A" & Lastrow)
    If cel.Value Like "*" & activityNumber & "*" Then
    hit = cel.Offset(, 1).Value
       coppy.Add hit
    End If
Next cel
For i = 1 To coppy.Count
Sheets("Sheet1").Range("A" & 2 + i).EntireRow.Insert
Sheets("Sheet1").Range("A" & 2 + i).Value = coppy(i)
Next i
End Sub

Answer 2

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

'dims for the loop
Dim cel As Range, Lastrow As Double, i As Integer
i = 0

    'determine last row of your filled data to avoid infinite loop or calculating to end of data
    Lastrow = SubTaskWs.Range("A" & Rows.Count).End(xlUp).Row

    'Loop to identify target rows and insert them inot spreadhseet in exisitng format
    For Each cel In SubTaskWs.Range("A1:A" & Lastrow)
        If cel.value Like "#" & activityNumber Then
        'Insert row at the last position of Activity table
        deliveryWs.Range("A" + CStr(delivActivEnd) + i).EntireRow.Insert

        ' Copy formatting from line above
        Call copyFormattingAbove(deliveryWs, "A" & CStr(delivActivEnd) + 1)

        'copy cell offset hit to newly inserted row
        deliveryWs.Range("A" & CStr(delivActivEnd) + i).value = cel.Offset(, 1)

        ' Number Deliverable
        deliveryNum = deliveryWs.Range("B" & CStr(delivActivEnd - 1)) + (0.1 * i)
        deliveryWs.Range("B" & CStr(delivActivEnd) + i) = deliveryNum

        ' Update sum of workload for activity
        Call updateActivityWorkload(deliveryWs, activityNumber, delivActivStart, delivActivEnd)

        ' Create new line for deliverable on Delivery and Validation for Invoicing table
        Call updateInvoicingTable(deliveryWs, delivActivEnd, delivActivEnd - deliverablesStart)
        i = i + 1
        End If
    Next cel
End Sub

Я сохранил большую часть того, что вы пытались сделать в цикле, предполагая егоработал для вас уже. Что он делает, так это определяет последнюю строку в вашем рабочем листе SubTaskWs, а затем перебирает все строки в столбце A до последней. Когда найдено совпадение (аналогично тому, как работал оператор подсчета строк), запускается оператор if, и код создает новую строку и заполняет ее смещением совпадения. Затем выполняет все остальные обновления, которые вы добавили в цикл (без изменений).