Copy & paste cell after inserting blank row

[Dan]

I have an Excel sheet with two columns of data for which I would like to
format. I need to add two rows at each change in column A (the no. of rows
for the change to occur varies). Next I would like to copy the first cell in
column B where the change occurs in column A to one cell above column A
where the change occured (like a header). The following table describes what
I would like to do.

This is the data b4 processing.
A B
6 Data A 123
7 Data A 123
8 Data B 234
9 Data B 234

This is the format that I need after processing.
7 123
8 Data A 123
9 Data A 123
10
11 234
12 Data B 234
13 Data B 234

So far, I have managed to obtain the following code to add two rows at each
change of column A. I can't figure out how the copying and pasting is done
via code. Could someone help? Thanks.

Sub InsertTwoRowsAtChangesInColumn()
Dim i As Long
For i = ActiveSheet.UsedRange.Rows.Count To 6 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Cells(i, 1).EntireRow.Insert
Cells(i, 1).EntireRow.Insert
End If
Next i
End Sub

 

[Norman Jones]

Hi Dan,

Try:

Sub InsertTwoRowsAtChangesInColumn()
Dim i As Long
Dim CalcMode As Long

CalcMode = Application.Calculation

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

For i = ActiveSheet.UsedRange.Rows.Count To 6 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Cells(i, 1).Resize(2).EntireRow.Insert
Cells(i + 1, 1).Value = Cells(i + 2, 2).Value
End If
Next i

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

 

[Dan]

Works great, Norman. Thanks.

Hi Dan,

Try:

Sub InsertTwoRowsAtChangesInColumn()
Dim i As Long
Dim CalcMode As Long

CalcMode = Application.Calculation

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

For i = ActiveSheet.UsedRange.Rows.Count To 6 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Cells(i, 1).Resize(2).EntireRow.Insert
Cells(i + 1, 1).Value = Cells(i + 2, 2).Value
End If
Next i

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub