CODEWITHSUNDEEP
excelvba
Nolemonkey
Nolemonkey

Reputation: 159

Row Insert Macro not completing entire worksheet

I have the following macro to read lines on Sheet1 and insert that number of lines and copy the data on Sheet2. It works fine for only 1 iteration. 

Sub InsertRow()

Dim ws2 As Worksheet
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer

Set sh = Sheet1
Set ws2 = Sheet2

RowCount = 0
For Each rw In sh.Rows
    If sh.Cells(rw.Row, 1).Value = "" Then
        Exit For
    Else
        ws2.Rows(rw.Row).Copy
        ws2.Rows(rw.Row + 1).Insert Shift:=xlDown
    End If

RowCount = RowCount + 1

Next rw

ws2.Rows(1).Delete
MsgBox ("Done")

End Sub

I need help figuring out how to tell it keep going and not finish until it comes across two consecutive blank cells. The worksheet will always be separated by one blank row and then data until the end of the sheet. Right now I have removed the header because it always starts there and I get a bunch of duplicate header rows instead of data rows. Is there a way to tell it to start inserting at row 2 and then keep iterating until 2 consecutive blank rows? The delete needs to be at the end of each iteration because the insert will always be X and since one row already exists on Sheet2 I will always need X-1.

An example worksheet for Sheet1 is this, for each line that exists on Sheet2 it will insert a row and copy the data already in that row on sheet1. When all teh rows are inserted, I will then move Columns B, C, and D over to Sheet2 and delete Sheet1

ColA    ColB    ColC       ColD
Srvr    9          12      Data
Srvr2   7          22      Data
Srvr9   15         14      Data
Blank row    
Srvr3   17         18      Data
Srvr19  18         27      Data
blank row

Upvotes: 0

Views: 56

Answers (2)

Nolemonkey
Nolemonkey

Reputation: 159

I ended up going with the following to accomplish the task. @PartyHatPanda thanks for helping me find 2 empty rows back to back. I incorporated that into my final code. I added an ElseIf and that did the trick. To deal with the blank rows, I left them in there that way the rows line up with the copy and paste, then I wrote a delete sub to get rid of the blank rows. 

Sub InsertRow()

Dim ws2 As Worksheet
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer

Set sh = Sheet1
Set ws2 = Sheet2

RowCount = 0
For Each rw In sh.Rows
    If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row + 1, 1).Value = "" Then
        Exit For
    ElseIf sh.Cells(rw.Row, 1).Value = "" Then
        ws2.Rows(rw.Row).ClearContents
    Else
        ws2.Rows(rw.Row).Copy
        ws2.Rows(rw.Row + 1).Insert Shift:=xlDown
    End If

'RowCount = RowCount

Next rw

MsgBox ("Done")

End Sub

Upvotes: 1

PartyHatPanda
PartyHatPanda

Reputation: 724

A quick modification should continue the code until two blank rows:

Change If sh.Cells(rw.Row, 1).Value = "" Then to If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row+1, 1).Value = "" Then

I am not sure what you are asking at the end of your question though about starting to insert at row 2 and x-1, etc.

Upvotes: 1

Related Questions