CutList

[PeteM5]

Hi
I sort the data in column C and create a blank row before each value change in C and I put the calculation formula in G that will keep track of the values from the blank row up to the next blank row e.g. F2:F6.
But it doesn't work. It's not consistent and each row can count a different number of rows.

Sub FyllKolumnEOchFochInfogaTomRad()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim startRow As Long
    Dim sumRange As String
    Dim currentValue As String

    ' Ange arbetsbladet
    Set ws = ActiveSheet

    ' Hitta sista använda raden i kolumn C
    lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row

    ' Lägg till rubriker i rad 1
    ws.Cells(1, 1).Value = "DET."
    ws.Cells(1, 2).Value = "ANT."
    ws.Cells(1, 3).Value = "BENÄMNING"
    ws.Cells(1, 4).Value = "LÄNGD"
    ws.Cells(1, 5).Value = "TOTAL LÄNGD"
    ws.Cells(1, 6).Value = "ACKUMULERAD"
    ws.Cells(1, 7).Value = "ANTAL HELLÄNGDER"
    ws.Cells(1, 8).Value = "STORLEK"

    ' Steg 1: Fyll i kolumn E (E = D * B)
    For i = 2 To lastRow
        ws.Cells(i, 5).Value = ws.Cells(i, 4).Value * ws.Cells(i, 2).Value
    Next i

    ' Steg 2: Fyll i kolumn F (ACKUMULERAD)
    ws.Cells(2, 6).Value = ws.Cells(2, 5).Value
    For i = 3 To lastRow
        ws.Cells(i, 6).Value = ws.Cells(i - 1, 6).Value + ws.Cells(i, 5).Value
    Next i

    ' Steg 3: Sortera kolumn C från A till Ö
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("C2:C" & lastRow), Order:=xlAscending
    ws.Sort.SetRange ws.Range("A2:H" & lastRow)
    ws.Sort.Header = xlNo
    ws.Sort.Apply

    ' Steg 4: Infoga tom rad och lägg till formel i G
    startRow = 2 ' Startar på första dataraden
    For i = lastRow To 2 Step -1
        ' Kontrollera om värdet i kolumn C ändras
        If ws.Cells(i, 3).Value <> ws.Cells(i - 1, 3).Value Then
            ' Hämta värdet från kolumn C innan tom rad infogas
            currentValue = ws.Cells(i, 3).Value

            ' Infoga en tom rad
            ws.Rows(i).Insert Shift:=xlDown

            ' Skapa formel på den tomma raden i G (kolumn 7)
            sumRange = "E" & startRow & ":E" & (i - 1)
            ws.Cells(i + 1, 7).Formula = "=ROUNDUP(SUM(" & sumRange & ") / 6000, 0)"
            
            ' Sätt värdet i H-kolumnen (kolumn 7) till samma som i C-kolumnen på den nya tomma raden
            ws.Cells(i + 1, 8).Value = currentValue  ' H = C på samma rad

            ' Uppdatera startRow för nästa sektion
            startRow = i + 1
        End If
    Next i

    ' Anpassa kolumnbredden
    ws.Cells.EntireColumn.AutoFit

    MsgBox "Klart! Uppdateringar har gjorts, sortering och formler har lagts in.", vbInformation

End Sub

 

[StephenCrump]

Welcome to the Forum!

Does this work any better?

    startRow = lastRow ' Start at the end
    For i = lastRow To 2 Step -1
        ' Kontrollera om värdet i kolumn C ändras
        If ws.Cells(i, 3).Value <> ws.Cells(i - 1, 3).Value Then
            ' Hämta värdet från kolumn C innan tom rad infogas
            currentValue = ws.Cells(i, 3).Value
    
            ' Infoga en tom rad
            ws.Rows(i).Insert Shift:=xlDown
    
            ' Skapa formel på den tomma raden i G (kolumn 7)
            sumRange = "E" & startRow + 1 & ":E" & i + 1
            ws.Cells(i + 1, 7).Formula = "=ROUNDUP(SUM(" & sumRange & ") / 6000, 0)"
            
            ' Sätt värdet i H-kolumnen (kolumn 7) till samma som i C-kolumnen på den nya tomma raden
            ws.Cells(i + 1, 8).Value = currentValue  ' H = C på samma rad
    
            ' Uppdatera startRow för nästa sektion
            startRow = i - 1
        End If
    Next i

 

[PeteM5]

Thanks!
Excellent and thank you very much. This solved the problem.

 

[StephenCrump]

I'm glad it worked for you. Thanks for letting us know.