Insert rows and values

[Belleke]

I have this code

With Sheets ("d4E")
    For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
    If Cells(lRow, "A") <> Cells(lRow - 1, "A") And Cells(lRow, "C") <> "PM-REBUILT" Then Rows(lRow).EntireRow.Resize(2).Insert
Next lRow
End With

This gives me a result like this:
A B C (empty)
5152613 0113
(empty row)
(empty row)
5144100 0104
How can I have this result?
A B C
5152613 0113 PM-NEW
5152613 0113 PM-USED
5152613 0113 PM-REBUILT
51441000104 PM-NEW
......

 

[vletm]

Belleke
What would be there BEFORE You run that code?

 

[Belleke]

Hi vletm,
thanks for looking into my problem.
I attached an example , hope it is clear.

 

[vletm]

Belleke
Left side is Your 'Extend' and right top is snap copy from Your 'Raw data'.
... do You mean something like this?

... so so so,
Would You like to get three rows from one row to 'Extend'?
... always three rows?
... are those 'yellow cells' fixed?
... 'd4E'-sheet ... belongs to Your sample code.

 

[Belleke]

Hi vletm,
To answer your questions.
Yes, three rows from one row(Raw data) to Sheet Extend (always three rows)
The yellow cells are fixed (always the same text)
Complete code until now

Public Sub DDataTr3()
Dim fpath As String, fname As String
Dim sWB As Workbook, dWB As Workbook
Dim sRD As Worksheet
Dim d4E As Worksheet
Dim ar, ar1, j As Long, t As Long, lRow As Long
    'fpath = "Z:\Engineering\Spar2\Winshuttle Daily Loads"
        fpath = "C:\Users\Grote\Downloads\Robert"
        fname = "SPAR LOAD PROCESS WORKSHEET 2018.xlsx"
    Set sWB = ThisWorkbook
        Set sRD = sWB.Sheets("RAW DATA")
    Set dWB = Workbooks.Open(fpath & "\" & fname)
        Set d4E = dWB.Sheets("4X4 EXTEND")
With sRD
    ar = .Cells(1).CurrentRegion
    ReDim ar1(UBound(ar), 7)
    For j = 2 To UBound(ar)
          ar1(t, 0) = ar(j, 3)
          ar1(t, 1) = ar(j, 7)
          t = t + 1
    Next j
d4E.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(ar1) + 1, UBound(ar1, 2) + 1) = ar1
End With
With d4E
    For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
    If Cells(lRow, "A") <> Cells(lRow - 1, "A") And Cells(lRow, "C") <> "PM-REBUILT" Then Rows(lRow).EntireRow.Resize(2).Insert
Next lRow
End With
End Sub

Thank again for looking into my problem

 

[Belleke]

Hi, i found a solution.
This is my code.

Public Sub DDataTr3()
Dim fpath As String, fname As String, LastRow As String
Dim sWB As Workbook, dWB As Workbook
Dim sRD As Worksheet, d4E As Worksheet
Dim ar, ar1, j As Long, t As Long, lRow As Long
Dim i As Integer
    'fpath = "Z:\Engineering\Spar2\Winshuttle Daily Loads"
        fpath = "C:\Users\Grote\Downloads\Robert"
        fname = "SPAR LOAD PROCESS WORKSHEET 2018.xlsx"
    Set sWB = ThisWorkbook
        Set sRD = sWB.Sheets("RAW DATA")
    Set dWB = Workbooks.Open(fpath & "\" & fname)
        Set d4E = dWB.Sheets("4X4 EXTEND")
With sRD
    ar = .Cells(1).CurrentRegion
    ReDim ar1(UBound(ar), 7)
    For j = 2 To UBound(ar)
          ar1(t, 0) = ar(j, 3)
          ar1(t, 1) = ar(j, 7)
          t = t + 1
    Next j
d4E.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(ar1) + 1, UBound(ar1, 2) + 1) = ar1
End With
With d4E
For lRow = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
        If .Cells(lRow, "A") <> .Cells(lRow - 1, "A") And .Cells(lRow - 1, "C") <> "PM-REBUILT" _
        And .Cells(lRow - 1, "C") <> "Valuation type RMMG1-BWTAR" Then .Rows(lRow).EntireRow.Resize(2).Insert
  Next lRow
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To LastRow
        If .Cells(i, 1).Value <> "" And Cells(i, 1).Offset(1, 0).Value = "" Then
        .Cells(i, 1).Offset(1, 0).Value = .Cells(i, 1).Value
        .Cells(i, 1).Offset(2, 0).Value = .Cells(i, 1).Value
        .Cells(i, 2).Offset(1, 0).Value = .Cells(i, 2).Value
        .Cells(i, 2).Offset(2, 0).Value = .Cells(i, 2).Value
        .Cells(i, 3).Value = "PM-NEW"
        .Cells(i, 3).Offset(1, 0).Value = "PM-USED"
        .Cells(i, 3).Offset(2, 0).Value = "PM-REBUILT"
        End If
    Next i
End With
End Sub '

Thank you for your time.

 

[vletm]

Belleke ... yes, good to know.
even that would look more possible to work.
My version would be ... different ...
Lucky for me, that I didn't start to write it