VBA code for inserting multiple rows, copying and transposing data

[Barry NP]

Hi all,


I am hoping that the following is possible to be done with vba code. I have searched but am struggling to find code to cover all of this. I have broken this down into 3 separate stages below.


I have a set of data in an excel spreadsheet that runs from column A to Column K and 6000 rows. The columns will always be the same, but the rows can increase over time. A snapshot example of data below.

A	B	C	D	E	F	G	H	I	J	K
David	Jones	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Steve	Davies	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Barry	Roberts	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Mark	Nesling	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Dereck	Roberts	10.0	2019	2019	2020	2021	2022	2023	2024	2025
Ashely	Roberts	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Reece	Roberts	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Tony	Davies	10.0	2018	2019	2020	2021	2022	2023	2024	2025
Mary	Davies	10.0	2018	2019	2020	2021	2022	2023	2024	2025

<tbody>
</tbody>

What I am looking at achieving is this (probably with a separate macro for each part):


1) Firstly I need 7 rows inserted between each line so that for e.g. Row 1 will have David Jones, followed by 7 blank rows and on row 9 will be Steve Davies and so on to the last row of data (circa 6000 rows).



2) I then need the newly inserted 7 blank rows to be auto filled with the data of the row above for columns A to C only, so for e.g rows 2 to 8 will show David Jones 10.00 for columns A to C. Then row 9 will show Steve Davies 10.00 and I then need rows 9 to 16 to also show Steve Davies 10.00 and so on. I need this to be done for all data rows to the last row of data. Columns D to K do not need to be auto-filled with the years in the newly inserted blank rows.



3) The last part that I am hoping to achieve is to cut and transpose the years for each row in columns D to K and to paste down in column D.


This needs to be done to the last row of data.


So what I would expect to see is the e.g. below with no data in columns E to K and years in column D.

A	B	C	D	E	F	G	H	I	J	K
David	Jones	10.0	2018
David	Jones	10.0	2019
David	Jones	10.0	2020
David	Jones	10.0	2021
David	Jones	10.0	2022
David	Jones	10.0	2023
David	Jones	10.0	2024
David	Jones	10.0	2025
Steve	Davies	10.0	2018
Steve	Davies	10.0	2019
Steve	Davies	10.0	2020
Steve	Davies	10.0	2021
Steve	Davies	10.0	2022
Steve	Davies	10.0	2023
Steve	Davies	10.0	2024
Steve	Davies	10.0	2025

<tbody>
</tbody>

This is a work project, so any help on this would be very, very gratefully received. I am an intermediate user of VBA and this has so far stumped me.


Keeping my fingers crossed on this one, so if you can assist it would be a massive help to me.


If you need any further clarification, please let me know.


Many thanks,


Barry.

 

[Barry NP]

No probs. That would be great if you would be able to take a look. No rush now as it's the weekend so I won't be looking at this again until Monday. Many thanks for all you help with this. It is greatly appreciated. Barry.

 

[Peter_SSs]

This will transfer all formatting from source to destination. However, be warned, it will take several minutes to run for the amount of data you have so you might want to make a cup of tea while it runs.

Sub Rearrange_v2()
  Dim i As Long, nr As Long
  
  nr = 2
  Application.ScreenUpdating = False
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Cells(i, 1).Resize(, 3).Copy Destination:=Cells(nr, "N").Resize(8)
    Cells(i, 4).Resize(, 8).Copy
    Cells(nr, "Q").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    nr = nr + 8
  Next i
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

This will run much faster (about 1 second for me), but only looks for, and transfers, red font in the 'Year' columns to the 4th column of the results.

Sub Rearrange_v3()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  
  With Range("A2", Range("K" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To 8 * UBound(a), 1 To 4)
    For i = 1 To UBound(a)
      For j = 4 To 11
        k = k + 1
        b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 3): b(k, 4) = a(i, j)
        If .Cells(i, j).Font.Color = vbRed Then b(k, 4) = b(k, 4) & "#"
      Next j
    Next i
  End With
  Application.ScreenUpdating = False
  Range("N2").Resize(UBound(b), 4).Value = b
  With Columns("Q")
    On Error Resume Next
    .SpecialCells(xlConstants, xlTextValues).Font.Color = vbRed
    On Error GoTo 0
    .Replace What:="#", Replacement:="", LookAt:=xlPart
  End With
  Application.ScreenUpdating = True
End Sub

 

[Barry NP]

That's fantastic. I will use this today and will let you know if all ok. Many thanks for this. Thus is that last part that is required. I will use the latter code hoping it will run quickly. I will confirm back to you once I have given it a go.

 

[Peter_SSs]

That's fantastic. I will use this today and will let you know if all ok. Many thanks for this. Thus is that last part that is required. I will use the latter code hoping it will run quickly. I will confirm back to you once I have given it a go.

You're welcome. Look forward to hearing how it goes for you.

 

[Barry NP]

Hi Peter. Just to let you know the code worked like a dream. I used the second code which only took a few seconds longer to run and it did show the data in red font as required. Many thanks for this. It's been a great help. Barry.

 

[Peter_SSs]

Hi Peter. Just to let you know the code worked like a dream. I used the second code which only took a few seconds longer to run and it did show the data in red font as required. Many thanks for this. It's been a great help. Barry.

Cheers. Thanks for the confirmation. Glad it worked as required.