VBA - Problems finding second last row and copying text

[Togora]

Hi All,

I have this code which adds blank rows at points on a table where names change over from one to the next.

Bob
Bob
      New blank row here
Anne
Anne
      New blank row here
etc
etc
      etc
Tom
Tom
Total 

Note - No new row between Tom and total

Sub InsertRowsAtValueChangeColumnB()
  Dim X As Long, LastRow As Long
  Const DataCol As String = "A"
  Const StartRow = 4
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
  Application.ScreenUpdating = False
  For X = LastRow To StartRow + 1 Step -1
    If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert
  Next
  Application.ScreenUpdating = True
End Sub

This code works fine between row 4 and the last row but I have struggled to get it to work between row 4 and the second to last row, adding this stops a blank row being introduce just before the totals row.

Also, I need to find each of the new empty cells in column B and copy and paste into it the value from the cell below and to the left - column A. For example for new empty cell B10 the value to be copied and pasted into it would be taken from cell A11 so on and so forth.

Any help or pointers would be very much appreciated

 

[JoeMo]

Does this do what you want?

Sub Togora()
Dim x As Long, LastRow As Long, c As Range
Const DataCol As String = "A"
Const StartRow As Long = 4
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row - 1    'Assumes last row is Total row
Application.ScreenUpdating = False
For x = LastRow To StartRow + 1 Step -1
    If Cells(x, DataCol) <> Cells(x - 1, DataCol) Then Cells(x, DataCol).EntireRow.Insert
Next x
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
On Error Resume Next
For Each c In Range(Cells(StartRow, Columns(DataCol).Offset(0, 1).Column), Cells(LastRow, Columns(DataCol).Offset(0, 1).Column)).SpecialCells(xlCellTypeBlanks)
    If IsEmpty(c) Then c.Value = c.Offset(1, -1).Value
Next c
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

 

[BKTK9]

Hope this helps

Sub InsertRowsAtValueChangeColumnB()  Dim X As Long, LastRow As Long
  Dim checked_cell As String
  Dim cell_above As String
  
  Const DataCol As String = "A"
  Const DataColOffset As String = "B"
  
  'I do not get it why you have started - in this case - from 4th row
  Const StartRow = 1
  
  'last row - 1 returns cell after total, thus no problem with inserting blank above it
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row - 1
  
  Application.ScreenUpdating = False
  
  For X = LastRow To StartRow + 1 Step -1
    'added those two to make code look nicer in conditions
    checked_cell = Cells(X, DataCol).Value
    cell_above = Cells(X - 1, DataCol).Value
    
    If checked_cell <> cell_above _
        And cell_above <> "" _
        And checked_cell <> "" Then
        
        Rows(X).Insert
        'adding the value from cell above as offset to new blank
        Cells(X, DataColOffset).Value = cell_above
        
    End If
    
  Next
  
  Application.ScreenUpdating = True
  
End Sub

 

[Togora]

It did the following:

1. Provided blank rows - sweet
2. Didn't create a row between the last name and total on the 2nd before last and final row - cool
3. Didn't copy over the names to column B - slightly tearful, or perhaps welling up a little.

So close but nice try.

 

[Togora]

Thanks for your code.

1. It created blank rows - great
2. Didn't create a blank row in the second to last row - cool
3. But it didn't get to copying and pasting the values in to column B from column A

So close and nice coding too.

 

[Fluff]

How about

Sub InsertRowsAtValueChangeColumnB()
  Dim X As Long, LastRow As Long
  Const DataCol As String = "A"
  Const StartRow = 4
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Offset(-1).Row
  Application.ScreenUpdating = False
  For X = LastRow To StartRow + 1 Step -1
    If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then
      Rows(X).Insert
      Cells(X, DataCol).Offset(, 1) = Cells(X + 1, DataCol).Value
   End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Togora]

It is still working as before - Unfortunately but it is very smooth code. Thanks for the effort.

 

[Fluff]

If none of the codes are doing what you want, you will need to explain how/why they are not what you want.

 

[JoeMo]

Additionally, you might consider telling us which of the multiple codes offered you are addressing when you comment on your assessment of any of them.

 

[Togora]

Hi Fluff and BKTK9,

Sorry for not getting back to you both more quickly.

As I have stated previously both codes provided are adding the blank rows in exactly the way I require them to so many thanks to your good self and BKTK9 for that.

The only unsolved problem is the copy and paste which perhaps i have not been very clear about.

Here is an example of what I mean.

Name	Area	Revenue
	Bob
Bob	East	£23,000
Bob	East	£26,000
Bob	East	£24,000
	Sally
Sally	West	£29,000
Sally	West	£26,000
Sally	West	£32,000
	Tara
Tara	North	£15,000
Tara	North	£22,000
Tara	North	£28,000
	Jim
Jim	South	£24,000
Jim	South	£29,000
Jim	South	£36,000
Total		£314,000

<tbody>
</tbody>

The intention is that the first occurrence of the name in column A (in bold) is copied and pasted into column B (also in bold).

Hopefully this is clearer. If not please feel free to ask for clarification.

Again many thanks for all the excellent work you have both done to date, it is appreciated.

Thanks in advance