Inserting Rows Based On 8 Rows Per Mile in a Data Set

Hello community

I was hoping someone could help me with a very difficult problem which I just cannot over come.

I am given a report, which contains data in column A B C.

The data in these columns represent distance along the highway.

Column A represents the Start of the Road in Miles.

Column B represents the Start of a section of road in Yards.

Column C represents the End of a section of road in Yards.

So 29 0 220 would the road section 29Miles 0Yards to 220Yards

The data should be presented such that each mile in the report should be composed of exactly 8 rows in whole yards, where each row represents 220yards of road for example:-

Aa.JPG

The problem is that the data is never presented in such a way, often it is presented in the following way:-

Bb.JPG

As you can see 30 mile only has 1 row which is just 22 yards and 31 mile Help.xls4 rows associated with it.

I need to format the data such that if there are less then 8 rows representing a mile then the start row of the mile is copied until there are 8 rows for that mile for example:-

Cc.JPG

As you can see the green cells are the inserted rows to make up 8 rows per mile.

Is there anyone out there who can help me I have been struggling with this for so long that I am going crazy.

I cannot seem to upload my raw my email is unomo@hotmail.com I can email it to you.

Thanks

Hi Mark-
1) What are your columns?
2) What is your first row of data?
3) What is your last row of data?
4) Are there any blank rows within the data?
5) Are there any missing mile numbers, or is it a complete sequence?

Try this:-
Your actual data assumed to start "A2".
Result start "E1".

Sub MG23Apr23
Dim Rng As Range, Dn As Range, n As Long, Q As Variant, Ac As Long, c As Long
Dim nRay()
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
        ReDim Ray(1 To Rng.Count, 1 To 2)
        Ray(1, 1) = Dn.Offset(, 1).Value
        Ray(1, 2) = Dn.Offset(, 2).Value
        .Add Dn.Value, Array(Ray, 1)
    Else
        Q = .Item(Dn.Value)
            Q(1) = Q(1) + 1
            Q(0)(Q(1), 1) = Dn.Offset(, 1).Value
            Q(0)(Q(1), 2) = Dn.Offset(, 2).Value
        .Item(Dn.Value) = Q
    End If
Next
Dim K As Variant, p As Variant
    For Each K In .Keys
        If .Item(K)(1) < 8 Then
            For Ac = 1 To 8 - .Item(K)(1)
                c = c + 1
                ReDim Preserve nRay(1 To 3, 1 To c)
                nRay(1, c) = K
                nRay(2, c) = .Item(K)(0)(1, 1)
                nRay(3, c) = .Item(K)(0)(1, 2)
            Next Ac
        End If
        For n = 1 To .Item(K)(1)
            c = c + 1
            ReDim Preserve nRay(1 To 3, 1 To c)
            nRay(1, c) = K
            nRay(2, c) = .Item(K)(0)(n, 1)
            nRay(3, c) = .Item(K)(0)(n, 2)
        Next n
  Next K
End With
Range("E1").Resize(c, 3) = Application.Transpose(nRay)
End Sub

Regards Mick

Try

Sub test()
For x = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    If Cells(x, 1) <> Cells(x - 1, 1) Then
        r = Application.CountIf(Range("A:A"), Cells(x, 1))
        If r <> 8 Then
            arr = Range("A" & x, "C" & x)
            Cells(x, 1).Resize(8 - r).EntireRow.Insert
            Cells(x, 1).Resize(8 - r, 3) = arr
        End If
    End If
Next
End Sub

Kind regards
Leo