AW: komplexes zeilenverschieben
05.11.2007 09:51:00
Chris
Servus ,
keine Ahnung, ob das noch relevant ist:
Hier ein Makro (bzw. 3) für dein Beispiel:
Einzige Bedingung der Anfang der Blöcke muss in Spalte C sein und die Leerzeilen sollten gelöscht sein.
Option Explicit
Sub t()
Dim SucheB As Range
Dim SucheC As Range
Dim FindeB As Range, FindeC As Range
Dim LetzteB As Long, letzteC As Long, wsLetzte As Long
Dim zählerBE As Double, zählerCE As Double
Dim zählerBL As Double, zählerCL As Double
Dim strErsteB As String, strErsteC As String
LetzteB = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
letzteC = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows.Count)
Sheets.Add After:=Sheets(1)
If LetzteB > letzteC Then
wsLetzte = LetzteB
Else
wsLetzte = letzteC
End If
Sheets(1).Range("A1:N" & wsLetzte).Copy ActiveSheet.Range("A1")
With ActiveSheet
.Columns("E:D").Insert
If .Range("B1") "" Then
.Range("D1") = "ErsteB1"
zählerBE = 1
Else
zählerBE = 0
End If
If .Range("C1") "" Then
.Range("E1") = "ErsteC1"
zählerCE = 1
Else
zählerCE = 0
End If
On Error Resume Next
Set FindeB = .Range("B1:B" & LetzteB + 1)
Set SucheB = FindeB.Find(what:="", LookAt:=xlWhole)
If Not SucheB Is Nothing Then
strErsteB = SucheB.Address
Do
If SucheB.Offset(-1, 0) "" Then
zählerBL = zählerBL + 1
SucheB.Offset(-1, 2) = "LetzteB" & zählerBL
End If
If SucheB.Offset(1, 0) "" Then
zählerBE = zählerBE + 1
SucheB.Offset(1, 2) = "ErsteB" & zählerBE
End If
Set SucheB = FindeB.FindNext(SucheB)
Loop While Not SucheB Is Nothing And SucheB.Address strErsteB
End If
Set FindeC = .Range("C1:C" & letzteC + 1)
Set SucheC = FindeC.Find(what:="", LookAt:=xlWhole)
If Not SucheC Is Nothing Then
strErsteC = SucheC.Address
Do
If SucheC.Offset(-1, 0) "" Then
zählerCL = zählerCL + 1
SucheC.Offset(-1, 2) = "LetzteC" & zählerCL
End If
If SucheC.Offset(1, 0) "" Then
zählerCE = zählerCE + 1
SucheC.Offset(1, 2) = "ErsteC" & zählerCE
End If
Set SucheC = FindeC.FindNext(SucheC)
Loop While Not SucheC Is Nothing And SucheC.Address strErsteC
End If
End With
Set SucheB = Nothing
Set SucheC = Nothing
Set FindeB = Nothing
Set FindeC = Nothing
Call tt
End Sub
Sub tt()
Dim SucheD As Range, FindeE As Range, FindeD As Range
Dim y As Long, letzteD As Long, letzteE As Long
Dim Suche As Range, FindeS As Range, SucheE As Range
Dim strErsteD As String, strZiffer As String
Dim Übergabe As Double, Differenz As Double
Dim letzteDRow As Long, letzteERow As Long, ErsteERow As Long, ErsteDRow As Long
With ActiveSheet
letzteD = IIf(IsEmpty(.Cells(Rows.Count, 4)), .Cells(Rows.Count, 4).End(xlUp).Row, Rows. _
Count)
letzteE = IIf(IsEmpty(.Cells(Rows.Count, 5)), .Cells(Rows.Count, 5).End(xlUp).Row, Rows. _
Count)
Set FindeS = .Range("D1:D" & letzteD)
Set Suche = FindeS.Find(what:="LetzteB" & "*", LookAt:=xlWhole)
If Not Suche Is Nothing Then
strErsteD = Suche.Address
Do
strZiffer = Right(Suche, Len(Suche) - 7)
Set Suche = FindeS.FindNext(Suche)
Loop While Not Suche Is Nothing And Suche.Address strErsteD
End If
Übergabe = strZiffer
Differenz = Übergabe - 1
For y = 1 To Differenz
Set FindeD = .Range("D1:D" & letzteD)
Set SucheD = FindeD.Find(what:="ErsteB" & y + 1, LookAt:=xlWhole)
If Not SucheD Is Nothing Then
letzteDRow = SucheD.Row
End If
Set FindeE = .Range("E1:E" & letzteE)
Set SucheE = FindeE.Find(what:="LetzteC" & y, LookAt:=xlWhole)
If Not SucheE Is Nothing Then
ErsteERow = SucheE.Row
End If
Dim xy As Double
xy = ErsteERow - letzteDRow + 1
If Not xy
Sub aus()
Dim SucheLeer As Range, FindeLeer As Range
Dim LeerRowB As Long, LeerRowC As Long
Dim LetzteLeerB As Long, LetzteLeerC As Long
With ActiveSheet
LetzteLeerB = IIf(IsEmpty(.Cells(Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, _
Rows.Count)
LetzteLeerC = IIf(IsEmpty(.Cells(Rows.Count, 3)), .Cells(Rows.Count, 3).End(xlUp).Row, _
Rows.Count)
Set FindeLeer = .Range("B1:B" & LetzteLeerB)
Set SucheLeer = FindeLeer.Find(what:="", LookAt:=xlWhole)
If Not SucheLeer Is Nothing Then
LeerRowB = SucheLeer.Row
End If
Set FindeLeer = Nothing
Set SucheLeer = Nothing
Set FindeLeer = .Range("C1:C" & LetzteLeerC)
Set SucheLeer = FindeLeer.Find(what:="*", LookAt:=xlWhole)
If Not SucheLeer Is Nothing Then
LeerRowC = SucheLeer.Row
End If
If LeerRowC
Gruß
Chris