Insert rows based on countif value

[Jmac2604]

I have the follwing code which will the data from sheet1 and count the occurence in sheet 2 and then copy the data multiple times based on that countif value. But Instead of just copying it needs to insert rows and then copy the data based on the countif value from sheet 2. Can anyone help me on this?

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Byte, StartCell As Range
Dim nList As Range, Ce As Range
Dim LastRow As Range

Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
Set nList = ws2.Range("C5:C9")
Set StartCell = ws2.Range("D5")

For Each Ce In nList
i = Application.WorksheetFunction.CountIf(ws1.Columns(1), Ce)
If i > 0 Then StartCell.Rows.Resize(i, 1) = Ce
Set StartCell = StartCell.Offset(i, 0)

Next Ce
End Sub


How I am getting the result is:

Expected is :

 

[Joe4]

Welcome to the Board!

Can you show us what the original data you have looks like, so we can see how that is structured?

I think there may also be some issues with your sheet references.
Note that you have "ws1" set to "Sheet2", and "ws2" set to "Sheet1".
That, while seemingly a little bit backwards, isn't necessarily wrong. But I wonder if that may be confusing you, as I question the sheets/ranges you are using in the COUNTIF formula.

 

[Jmac2604]

Hi Joe4,

Thanks for the reply. I have attached the sheet 1 and 2 data snap.

 

[Joe4]

See if those does what you want:

Sub MyTest()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long
    Dim LastRow As Long
    Dim r As Long
    Dim str As String

    Application.ScreenUpdating = False

    Set ws1 = Sheets("Sheet2")
    Set ws2 = Sheets("Sheet1")

'   Loop through rows on sheet1 backwards
    For r = 9 To 5 Step -1
'       Get value to count from column C in row
        str = ws2.Cells(r, "C")
'       Count number on other sheet in column A
        i = Application.WorksheetFunction.CountIf(ws1.Columns(1), str)
'       Insert blank rows under current row
        If i > 1 Then ws2.Rows(r + 1 & ":" & r + i - 1).Insert
'       Populate column D
        ws2.Range(Cells(r, "D"), Cells(r + i - 1, "D")) = str
    Next r
       
    Application.ScreenUpdating = True

End Sub

 

[Jmac2604]

Yes the code works. Thank you so much!!

 

[Joe4]

You are welcome.
Glad I was able to help!

 

[Jmac2604]

Just one query . Is it possible to run the loop from top to bottom and not Backwards?

 

[Joe4]

Just one query . Is it possible to run the loop from top to bottom and not Backwards?

Why does that matter?

As a general rule of thumb, if you are looping through rows of data, and either inserting or deleting rows, it is always better to "work from the bottom up", otherwise you can end up missing rows or duplicating rows, as you are changing the size of the range as you are looping through it.

Here is a simple example. Let's say that you have four rows of data, something like this:
1 - keep
2 - delete
3 - delete
4 - keep
and you want to loop through the rows and delete the rows that end in "delete".
If you loop through the rows, nothing happens on row 1.
However, on row 2, you will delete that row, which then moves row 3 up to the spot previously occupied by row 2.
So on the next iteration of the loop, it is looking in row 3, which is now occupied by "4-keep", as "3-delete" moved up to row 2.
As such, "3-delete" gets skipped over completely.
See the problem?

By working from the bottom-up, we are not changing the range of any of the rows we have not touched yet, so we avoid that issue.

 

[Jmac2604]

Hi, Thanks a lot for the clarification.

I have included some filtering options in the code and I am trying copy the filtered range in another worksheet But getting below error. Can you please help me on this

 

[Joe4]

I have included some filtering options in the code and I am trying copy the filtered range in another worksheet But getting below error. Can you please help me on this

That is a whole different question, and as such, requires its own new thread.