如何在VBA中使用count来计算链接到指定数字的活动数？

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

enter image description here

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语句，代码创建新行，并用匹配项的偏移量填充它。然后执行您在循环中添加的所有其他更新（保持不变）。