Cut rows after cell value and insert above cell value

[Deverti]

Im dealing with a slightly screwed up software export, what im trying to do right now is:

cut all rows with content below my case ("Total Ertrag") until the next empty row (cut without the empty row)
and paste it above my case

im having a hard time getting a clue as to how i should go about defining the cut range

any hints d be much appreciated ~

Sub FixList()
   Dim vL As Range, vArea As Areas
   Set vArea = Range("A:A").SpecialCells(xlConstants).Areas
  
   For Each vL In Range("A1", Range("A" & Rows.Count).End(xlUp))
      Select Case vL.Value
         Case "Total Ertrag"
            vL.Offset(1).Select
            'vArea ?
            'vArea.EntireRow.Cut
            'vL.Offset(-1).Insert
      End Select
   Next vL
End Sub

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Deverti]

Box

app.box.com

alright this should be publicly accessible now

i marked my areas of interest with colors. i need to cut the orange rows and paste it into the green row.
the example sheet is a fragment of the entire data and the number of rows within each orange area varies.

 

[mumps]

Try:

Sub MoveRows()
    Application.ScreenUpdating = False
    Dim fnd As Range, x As Long, y As Long, z As Long, cnt As Long
    cnt = WorksheetFunction.CountIf(Range("A:A"), "Total Ertrag")
    Set fnd = Range("A:A").Find("Total Ertrag", LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        Do
            z = z + 1
            If fnd.Offset(1) <> "" Then
                x = fnd.CurrentRegion.Rows.Count
                y = fnd.CurrentRegion.Cells(2).Row
                Rows(y).EntireRow.Resize(x - 1).Cut
                Rows(fnd.Row).Insert
            End If
            Set fnd = Range("A:A").FindNext(fnd)
        Loop While z <= cnt
    End If
    Application.ScreenUpdating = True
End Sub