Solved Macro To Insert Rows If Cells Are Occupied And Copy Data

September 21, 2016 at 08:39:14
Specs: Windows 64
Hi, I need a macro that will insert rows based on if cells in rows contain data and copy them over to newly created rows. So, if rows B:D have values then I need rows inserted below based on how many are occupied and the data from C:D copied in the newly inserted rows in B (kind of Transposing the value).

Screencast (http://screencast.com/t/NTLcqKU1UO3) needs to be become screencast (http://screencast.com/t/gdOkhrgIei4Z)

I would greatly appreciate any help. Thanks


See More: Macro To Insert Rows If Cells Are Occupied And Copy Data

Reply ↓  Report •


✔ Best Answer
September 22, 2016 at 07:01:27
I believe that this code will give you the results you showed in the output screencast.

There is one key assumption that was made:

If a row has data in Column D, then it also has data in Column C.

This is OK:

          A        B         C          D
1       So no    Data 1    Data 2     Data 3
2        1       Apple     Banana     Orange

This is not:

          A        B         C          D
1       So no	 Data 1	   Data 2     Data 3
2        1       Apple                Orange

If that situation needs to be dealt with, let me know.

Option Explicit
Sub InsertFill()
Dim lastRw As Long
Dim rw As Long
Dim numRws As Long
Dim insRw As Long
Dim myRng As String
Application.ScreenUpdating = False
'Determine last row with data in Column A
 lastRw = Cells(Rows.Count, 1).End(xlUp).Row
'Loop through Rows
   For rw = lastRw To 2 Step -1
'Count Cells in B:D that contain data
'If C contains data, B must contain data
      myRng = Range(Cells(rw, "C"), Cells(rw, "D")).Address
      numRws = Application.WorksheetFunction.CountA(Range(myRng))
'Insert Rows based on count
        For insRw = rw To rw + numRws - 1
         Cells(insRw + 1, 1).EntireRow.Insert
'Copy entire Row, Delete B to Shift C Over
          Cells(insRw, 1).EntireRow.Copy Cells(insRw + 1, 1)
          Cells(insRw + 1, "B").Delete shift:=xlToLeft
        Next
   Next
'Determine last row with data in Column A
'Clear original data from C:D
    lastRw = Cells(Rows.Count, 1).End(xlUp).Row
      Range(Cells(2, "C"), Cells(lastRw, "D")).ClearContents
    Application.ScreenUpdating = True
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.



#1
September 21, 2016 at 08:45:45
B:D are Columns, not Rows, therefore I'm not really sure what you are trying to do.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

message edited by DerbyDad03


Reply ↓  Report •

#2
September 21, 2016 at 09:11:54
my bad! I meant rows in column B:D. Hope that's clear now. Also, I'm still trying to use codes from your answers on previous threads in this forum. Thanks again.

message edited by dollar5474


Reply ↓  Report •

#3
September 21, 2016 at 09:31:42
Hi "DerbyDad03" I could not make those previous codes to work. Waiting for you help. Please help me out if you have the time to spare. I need to do this on over 9000 rows with data in more than 15 columns.

FYI, to keep things simple you can use the example from these screenshot:

Original: http://screencast.com/t/NTLcqKU1UO3

Result: http://screencast.com/t/gdOkhrgIei4Z


Thanks again.


Reply ↓  Report •

Related Solutions

#4
September 21, 2016 at 09:38:22

Reply ↓  Report •

#5
September 21, 2016 at 09:42:13
This thread: http://www.computing.net/answers/of...

This only insert new rows.

Code you suggested:

Option Explicit
Sub InsertFill()
Dim lastRw As Long
Dim rw As Long
Dim numRws As Long
Dim insRw As Long
Dim myRng As String
Application.ScreenUpdating = False
'Determine last row with data in Column A
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
'Loop through Rows
For rw = lastRw To 2 Step -1
'Count Cells in I:Q that contain data
myRng = Range(Cells(rw, "I"), Cells(rw, "Q")).Address
numRws = Application.WorksheetFunction.CountA(Range(myRng))
'Insert Rows based on count
For insRw = rw To rw + numRws - 1
Cells(insRw + 1, 1).EntireRow.Insert
'Copy entire Row, Clear I:P in new Row
Cells(insRw, 1).EntireRow.Copy Cells(insRw + 1, 1)
Range(Cells(insRw + 1, "I"), Cells(insRw + 1, "P")).ClearContents
Next
Next
Application.ScreenUpdating = True
End Sub

Thanks.


Reply ↓  Report •

#6
September 21, 2016 at 10:00:08
I post a lot of code in this forum and certainly don't remember everything I post.

The code that you posted inserts new Row based on data in Columns I:Q because that is what was asked for. The code also clears Columns I:P in the new Rows because the poster only wanted certain columns copied to the new rows. It won't work for you because it doesn't match your requirements.

In addition, your screenshots don't match what you asked for.

You said: "the data from C:D copied in the newly inserted rows in B"

In your output screenshot I don't see any data in C:D. "copied" data is not removed, "cut" data is.

I don't know whether to write code based on your words or on your screenshots.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#7
September 21, 2016 at 11:06:17
apologies for the confusion! what you explained is correct. is it possible to write code based on my screenshots?

Thank you a lot!


Reply ↓  Report •

#8
September 22, 2016 at 07:01:27
✔ Best Answer
I believe that this code will give you the results you showed in the output screencast.

There is one key assumption that was made:

If a row has data in Column D, then it also has data in Column C.

This is OK:

          A        B         C          D
1       So no    Data 1    Data 2     Data 3
2        1       Apple     Banana     Orange

This is not:

          A        B         C          D
1       So no	 Data 1	   Data 2     Data 3
2        1       Apple                Orange

If that situation needs to be dealt with, let me know.

Option Explicit
Sub InsertFill()
Dim lastRw As Long
Dim rw As Long
Dim numRws As Long
Dim insRw As Long
Dim myRng As String
Application.ScreenUpdating = False
'Determine last row with data in Column A
 lastRw = Cells(Rows.Count, 1).End(xlUp).Row
'Loop through Rows
   For rw = lastRw To 2 Step -1
'Count Cells in B:D that contain data
'If C contains data, B must contain data
      myRng = Range(Cells(rw, "C"), Cells(rw, "D")).Address
      numRws = Application.WorksheetFunction.CountA(Range(myRng))
'Insert Rows based on count
        For insRw = rw To rw + numRws - 1
         Cells(insRw + 1, 1).EntireRow.Insert
'Copy entire Row, Delete B to Shift C Over
          Cells(insRw, 1).EntireRow.Copy Cells(insRw + 1, 1)
          Cells(insRw + 1, "B").Delete shift:=xlToLeft
        Next
   Next
'Determine last row with data in Column A
'Clear original data from C:D
    lastRw = Cells(Rows.Count, 1).End(xlUp).Row
      Range(Cells(2, "C"), Cells(lastRw, "D")).ClearContents
    Application.ScreenUpdating = True
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#9
September 22, 2016 at 10:50:37
A million thanks to you! You are AWESOME!

Reply ↓  Report •


Ask Question