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

 

[Fluff]

Starting with data like

Excel 2013/2016
	A	B	C
4	Name	Area	Revenue
5	Bob	East	£23,000
6	Bob	East	£26,000
7	Bob	East	£24,000
8	Sally	West	£29,000
9	Sally	West	£26,000
10	Sally	West	£32,000
11	Tara	North	£15,000
12	Tara	North	£22,000
13	Tara	North	£28,000
14	Jim	South	£24,000
15	Jim	South	£29,000
16	Jim	South	£36,000
17	Total		£314,000
Sheet4

And running the code from post#6 I get

Excel 2013/2016
	A	B	C
4	Name	Area	Revenue
5		Bob
6	Bob	East	£23,000
7	Bob	East	£26,000
8	Bob	East	£24,000
9		Sally
10	Sally	West	£29,000
11	Sally	West	£26,000
12	Sally	West	£32,000
13		Tara
14	Tara	North	£15,000
15	Tara	North	£22,000
16	Tara	North	£28,000
17		Jim
18	Jim	South	£24,000
19	Jim	South	£29,000
20	Jim	South	£36,000
21	Total		£314,000
Sheet4

 

[Togora]

Good morning Fluff,

Yes your post shows the start and end of what I am trying to achieve. However the bolded text would only appear in column B and not in column A after it has been copied over.

I did of course copy + paste your code into the VBA editor and run it in my version of Excel - version 2019. It added the blank rows as required but did not copy and paste the text into the relevant cells.

The code is completely unchanged in all respects so why it is not working is baffling. I wouldn't have thought there were any differences between 2013/2016 but perhaps you know the answer to that.

Thanks again for your efforts.

 

[Fluff]

There is no reason why the code should not with 2016.
Are the names in col A hard values or formulae?
Also do you have any merged cells?

 

[Togora]

Hi Fluff,

I am using Excel 2019 so sorry if you thought otherwise. I had been referring to your code which is annotated above it with 2013/2016 in bold.

The names in column A are entered as plain text and the formatting is set to "General". Text wrapping was on so I removed it and retested but still I get the blank rows with not text copied and pasted into column B.

Finally, no cells within the spreadsheet are merged. I decided on that from day one so it removed the possibility of errors or issues arising from doing such a thing.

Hope this helps.

Thanks

 

[Togora]

Hi Fluff,

You are a genius!

Your code was working exactly as expected. The reason I didn't see the text was
there was because I had implemented conditional formatting when the spreadsheet
was in its infancy that changed the text colour to white. Doh!

So I'm very sorry you and the other providers of code where wasting your time
on this when in fact you implemented it correctly first time round.

If I may be cheeky can I ask how I can set the copied over text to bold? Then I
will go away and beat myself with a barbed stick.

Many, many thanks for your assistance once more.

 

[Fluff]

To make the font bold, try

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
      [COLOR=#ff0000]Cells(X, DataCol).Offset(, 1).Font.Bold = True[/COLOR]
   End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Togora]

Hi Fluff,

Perfect!

Many, many thanks for all your help.

Have a great weekend

 

[Fluff]

You're welcome & thanks for the feedback