nachgefragt und Lösungsvorschlag
10.06.2023 12:32:05
ralf_b
1. Die 1.Zeile des ersten Bereiches in deinem Wunschergebnis ist leer. Torstens Code läßt diese Zeile nicht leer.
2. Dein Wunschergebnis hat 16 Zeilen. Die Basis dazu aber nur 15.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
sbRemove 27, 50
sbRemove 92, 115
Application.ScreenUpdating = True
End Sub
Sub sbRemove(lStartrow&, lEndrow&)
Dim lloRow As Long, lloStart As Long, lloEnd As Long
With ActiveSheet
For lloRow = lEndrow To lStartrow Step -1 '.Cells(.Rows.Count, 2).End(xlUp).Row
If .Range("B" & lloRow).Value > "" And lloEnd = 0 Then
lloEnd = lloRow
End If
If .Range("B" & lloRow).Value = "" And lloEnd > 0 Then
lloStart = lloRow + 1
End If
If lloStart > 0 And lloEnd > 0 Then
.Range("B" & lloStart & ":B" & lloEnd).Cut Destination:=.Range("B" & lloStart - 1 & ":B" & lloEnd - 1)
lloRow = lEndrow + 1 '.Cells(.Rows.Count, 2).End(xlUp).Row + 1
lloStart = 0
lloEnd = 0
End If
Next
With .Range("B" & lStartrow & ":B" & lEndrow)
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
End With
End Sub