How to use count in VBA to count the number of activities linked to a number that is specified?

Question

I have attempted multiple times to do this, however i have not been successful.I have attached my code which includes user defined function which just find the last row in a designated area.

The aim of this is to insert the correct number of rows needed (Which is does correctly but the number of rows is backwards) and then fill these new rows with the information from another sheet within a loop. The information is found by cross referencing the activity number inputted with in Column A of the subtasks. Once a match is found, the ideal situation would be to then copy the contents of the C cell to the left of the match and paste within the the new columns inserted. any help will be appreciated as this is driving me crazy!



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

Any help would be greatly appreciated and would be very thankful!!! — Lawrence Forster, Sep 30 '19 at 21:03
Yes i tried to use this, but i found i could not get it to work — Lawrence Forster, Sep 30 '19 at 21:47
Always helps if you include what you tried, even if it didn't work, and explain what happened when you ran your code (error message, or ?) — Tim Williams, Sep 30 '19 at 22:04
Its just a user specified function. And it terms of using COUNTIF, i couldnt get the syntax right to make the calculation — Lawrence Forster, Oct 01 '19 at 07:37

Plutian · Answer 1 · 2019-10-01T13:06:01.767

1

When counting the amount of activities on your activity sheet, do you only need to count the amount of times your user defined number occurs in a range of cells containing just numbers? If so, this dumbed down version could easily do the trick when adapted and added to your code:

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

If there is more information in the cells than just the activity number, adapt like so:

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

EDIT as per the updated question the offset values of each hit needs to be copied. This is a bit more tricky than just counting the amount of hits. So I opted to add a loop which searches all cells in the spreadsheet, and add the offset of all hits to a collection. Then in sheet 1 another loop will insert a new row for each hit in the collection and past the value.

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

edited Oct 01 '19 at 13:06

answered Oct 01 '19 at 09:21

Plutian

2,276
3
14
23

Thank you very much, Using your code and a little bit of trial and error works perfectly. Now i am trying to get it to print information into the new inserted rows. For example, when it has found a row with a specified number in, it creates a row for each time this occurs (This has now been done). But what i want now is for it to print the cell value to the right of where the number was located. See pciture for example. – Lawrence Forster Oct 01 '19 at 09:35
Any ideas @Plutian – Lawrence Forster Oct 01 '19 at 10:23
This can be done by adding all hits to a collection I believe, and then pasting all collection values in the inserted cells. Give me some time and I'll update my answer. – Plutian Oct 01 '19 at 10:30
@LawrenceForster See revised answer. Good luck with adapting it! – Plutian Oct 01 '19 at 11:00
Hi @Plutian Sorry to ask so many questions. I have actually done the first part to the question as shown in code in orignial question (Sorry changed it again). I cant see to work out how i would use yours to then do whats required using the formula i already have. My friend wants the formula to be the same as it currently is. – Lawrence Forster Oct 01 '19 at 12:20
Sorry to ask again @Plutian, im really appreciative of the ffort youve gone to to help! – Lawrence Forster Oct 01 '19 at 13:04
@LawrenceForster I'm afraid you have me confused with your range of pre-defined functions which I do not know what they do. But you are trying to do everything in one loop. This is technically possible, but your logic is off. You need to determine the range in which you search, then loop through that entire range and find the hits, and offset them by 1. You can then add these hits to a collection, or add them directly to the sheet you want. But now you loop depending on the amount of hits you have, this wont work as you can't find your second hit since you can't tie it to your loop number. – Plutian Oct 01 '19 at 13:20
The custom functions just find the last row in the activity sheet or deliverable sheet, my friend made them not me. I have managed to get code that counts the amount of (input activity) values in column and then inserts said amount of lines. However i am just struggling with logging the counts and offset of counts. So you suggest using separate loops? – Lawrence Forster Oct 01 '19 at 13:48
It can be done with one loop. But the loop you have now iterates on the amount of values. This won't work. You can loop through the entire range where your data starts to where it ends and per hit insert a new line and the offset value in one go. This negates the need for counting the amount of hits and inserting lines for them altogether. – Plutian Oct 01 '19 at 13:57
Thanks for your help Pluitan, Has helped a lot. Im not sure i totally understand the logic or how to do this unfortunately. Its taken a lot of your time and im conscious not to be a nuisance so i may just leave it here to prevent from becoming annoying to you! thanks so much for your help, i have just got really confused over this. – Lawrence Forster Oct 01 '19 at 14:04
I'm sorry I wasn't able to help you any further, but trying to fix someone else's code is tricky at best, especially so if they didn't write most of it themselves either. I might come back to it if I have some time later this week to see if I can figure it out for you, as I don't like leaving things unfinished. But for now I have other things to attend to. If you do figure it out though, don't hesitate to answer your own question with your solution! – Plutian Oct 01 '19 at 14:13
I have added the whole code to maybe make things easier, again dont feel obliged to work on it! – Lawrence Forster Oct 02 '19 at 10:23

Plutian · Accepted Answer · 2019-10-02T16:36:33.123

0

I'm adding another answer, as my previous answer is more the outline for general loops. This will be tailored specifically to this code. I am confident this is the structure you need, but I haven't been able to test it without access to your data. I hope you'll be able to debug my inevitable typo's or errors. This needs to be inserted where the ival = application.worksheetfunction statement starts, and replaces that entire block till the end of the sub.

'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

I've preserved most of what you tried to do in the loop assuming it worked for you already. What it does is determine the last row in your SubTaskWs worksheet, then loop through all rows in column A to the last one. When a hit is found (similar to how the rows count statement worked) then the if statement is triggered and the code creates a new line, and fills it with the hit's offset. Then does whatever else updates you've added in the loop (left unchanged).

edited Oct 02 '19 at 16:36

answered Oct 02 '19 at 12:20

Plutian

2,276
3
14
23

Hi, I wish i had good news as I would like to finsih this and im guessing so do you! but unfortunately the offset function works, but it posts the hits starting from the bottom, so they arent in the same order as they appear in Sub Tasks. ANy ideas? – Lawrence Forster Oct 02 '19 at 16:04
Sorry for the many notifications, you had me quite confused for a second, but I've figured it out. As the row you're inserting it stays static, the newly inserted row pushes the last one down by one. I've added a counter to my answer which will make sure it's inserted after the last one. Should work fine now. – Plutian Oct 02 '19 at 16:14
Also, the tasks labelling e.g. 1.2,1.3, doesnt work, it just does 1.1., 1.1 and does not increase in increments – Lawrence Forster Oct 02 '19 at 16:18
You are a genius i am so thankful. However, the tasks still list in a reverse order. Do you think this has anything to do witht he use of xlUp.Row as it starts from bottom up? NOTE. Just tried replacing xlUP to xlDown and it didnt change anything – Lawrence Forster Oct 02 '19 at 16:21
It has nothing to do with the xlup.row, this is just to determine the last used row in your data. The most reliable way to do this is calculate the amount of rows, and substract the amount of unused rows after your data (xlup.row). It's odd but that has proven the most reliable method by [pretty much everyone](https://stackoverflow.com/a/38882823/11936678) Besides, the lastrow is only used to determine how long the range in your loop is. I'll take another look at reversing the order. – Plutian Oct 02 '19 at 16:32
Perhaps this last update will work. If not, I'll have to take another look tomorrow. – Plutian Oct 02 '19 at 16:37
Just a massive thank you @Plutian, you have saved my life and it works great. Few tweaks but im sure i can solve these! Made my life so much easier thank you so much!!!! – Lawrence Forster Oct 03 '19 at 08:29
You're very welcome, I am just happy it is working for you now. Probably one of the longest problems I've worked on since joining this site... – Plutian Oct 03 '19 at 08:33

How to use count in VBA to count the number of activities linked to a number that is specified?

2 Answers2