|
Sub Insertrowbelow()
'updateby Extendoffice
Worksheets("Budgetplanung").Activate
Dim i As Long
Dim xLast As Long
Dim xRng As Range
Dim xTxt As String
On Error Resume Next
xTxt = Application.ActiveWindow.RangeSelection.Address
Set xRng = Application.InputBox("Bitte Spalte B auswählen:", "Kutools for Excel", xTxt, , , , , 8)
If xRng Is Nothing Then Exit Sub
If (xRng.Columns.Count > 1) Then
MsgBox "Bitte wählen Sie maximal eine Spalte aus", , "Kutools for Excel"
Exit Sub
End If
xLast = xRng.Rows.Count
For i = xLast To 1 Step -1
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
If InStr(1, xRng.Cells(i, 1).Value, "Paket") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert Shift:=xlDown
End If
Next
End Sub
VG
|