if cell in range is not empty add row with that specific value and copy some other values

[jellevansoelen]

Hi excel macro expert,

I'm searching for a specific complex excel macro.

I have a document with more than 5000 rows. Each row has 10 columns. The first 3 colums (A,B,C) from a row is a default value. But from column D is different. Some cells has a value and some is empty. I'm looking for a macro/script which insert a new row by when the cell is not empty from column D. But with that specific value from cell D-E-F-G-H. And copy the default values of cell A,B,C.

Data is like:

A 12-10-2020 Plan A Plan B Plan C
B 16-10-2020 Plan A
C 25-10-2020 Plan A Plan B
D 27-10-2020 Plan A Plan C
E 29-10-2020 Plan A

End results would be like:
A 12-10-2020 Plan A
A 12-10-2020 Plan B
A 12-10-2020 Plan C
B 16-10-2020 Plan A
C 25-10-2020 Plan A
C 25-10-2020 Plan B
D 27-10-2020 Plan A
D 27-10-2020 Plan C
E 29-10-2020 Plan A

Hopefully you can understand me and someone can help me.

Tnx

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub jellevansoelen()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   With Sheets("Sheet1")
      Ary = Range("A2:J" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary) * 7, 1 To 3)
   
   For r = 1 To UBound(Ary)
      For c = 3 To 10
         If Ary(r, c) <> "" Then
            nr = nr + 1
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
            Nary(nr, 3) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 3).Value = Nary
End Sub

Change sheet names to suit.

 

[jellevansoelen]

Tnk you!

This script is working for me :

Sub SubNewRows()



'Declarations.

Dim RngSolidData As Range

Dim RngCheesyData As Range

Dim RngTarget As Range

Dim RngResult As Range

Dim DblCounter01 As Double



'Settings.

Set RngSolidData = Range("A1:D3")

Set RngCheesyData = RngSolidData.Offset(0, RngSolidData.Columns.Count).Resize(, 4)



'Creating a new sheet for the output.

Worksheets.Add



'Setting.

Set RngResult = Range("A1")



'Covering each cell in RngCheesyData.

For Each RngTarget In RngCheesyData



'Checking if the given cell is not empty.

If RngTarget.Value <> "" Then



'Reporting the row from RngSolidData.

RngSolidData.Rows(RngTarget.Row - RngCheesyData.Row + 1).Copy RngResult



'Reporting the data in RngTarget.

RngResult.Offset(0, RngSolidData.Columns.Count).Value = RngTarget.Value



'Setting RngResult for the next row.

Set RngResult = RngResult.Offset(1, 0)



End If

Next



End Sub

 

[Fluff]

Glad you sorted it & thanks for the feedback.