Macro Help - Loop to Tag a Cell with a Name and Add Rows based on a Counter

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
677
Office Version
  1. 2016
Platform
  1. MacOS
Hello All,

I have a block of Data Sheets("Data Entry").Rows(1:20).EntireRow that is copied x amount of times based on a variable which I have working at this point. Where I am getting stuck is I need to update a cell value based on a counter with a name and number incrementally. So for example, if my block mentioned above is copied 4 times, I would need to update Cell A4 with "Block 1" and then cell A24 with "Block 2", Cell 44 with "Block 3" and Cell 64 with "Block 4".

Once the blocks have been tagged, I have another variable on another sheet that would need to go into each of the blocks and Add rows based on the value. Each block already contains 15 rows of useable space but most blocks will need more than this so for this example:

Block 1 = Needs 17 Rows
Block 2 = Needs 30
Block 3 = Needs 30
Block 4 = Needs 30

The blocks will never need less than 15 rows but at times will only need 15 rows total.

My Counter for the variables is on Sheet "Schedule Report" Column T is used as a count for how many blocks are needed, Column U is the unique values that are driving all the counts, Column V is the Count of how many rows each block needs.

Marketing Timing Model v2.8.xlsb
TUV
1CounterUnique Release YearRow Count
2Block 1FY - 202017
3Block 2FY - 202130
4Block 3FY - 202230
5Block 4FY - 202330
Schedule Report


Here is my current code: (Missing the loop portion that defines how many rows are needed for each block)
Code:
Sub MakeUnique()

Dim ws1                 As Worksheet, ws2 As Worksheet
Dim vaData           As Variant, aOutput() As Variant
Dim colUnique     As Collection
Dim i                       As Long, LastR1 As Long, Count As String

Set ws1 = Sheets("Schedule Report")
Set ws2 = Sheets("Data Entry")

LastR1 = ws1.Cells(Rows.Count, "Q").End(xlUp).Row
Application.DisplayAlerts = False

    'Put the data in an array
    vaData = ws1.Range("Q2:Q" & LastR1).Value

    'Create a new collection
    Set colUnique = New Collection

    'Loop through the data
    For i = LBound(vaData, 1) To UBound(vaData, 1)
        'Collections can't have duplicate keys, so try to
        'add each item to the collection ignoring errors.
        'Only unique items will be added
        On Error Resume Next
            colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
        On Error GoTo 0
    Next i

    'size an array to write out to the sheet
    ReDim aOutput(1 To colUnique.Count, 1 To 1)

    'Loop through the collection and fill the output array
    For i = 1 To colUnique.Count
        aOutput(i, 1) = colUnique.Item(i)
    Next i

    'Write the unique values to column
    ws1.Range("U1").Value = "Unique Release Year"
    ws1.Range("U2").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    
    LastR1 = ws1.Cells(Rows.Count, "U").End(xlUp).Row   'Redefines the New LastR
        ws1.Range("T1").Value = "Counter"
                ws1.Range("T2:T" & LastR1).Formula = "=""Block "" & ROW()-1"
                    ws1.Range ("V1") > Value = "Row Count"
                        ws1.Range("V2:V" & LastR1).Formula = "=COUNTIF(Q:Q,U2)"
                
Count = Application.WorksheetFunction.CountA(ws1.Range("T2:T" & LastR1)) 'Defines how many times to copy the block of data

ws2.Rows("1:20").EntireRow.Copy Range("A1").Resize(20 * Count) 'Creates the Data Blocks

'Need loop here to look at Column T on ws1 to define how many rows to add to each block

End Sub
 

Some videos you may like

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

Watch MrExcel Video

Forum statistics

Threads
1,127,430
Messages
5,624,743
Members
416,046
Latest member
Elliottj2121

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top