AW: Gegenüberstellen von Werten mit Leerzeilen
02.02.2007 14:02:38
Werten
Hallo Sascha,
hier nochmal ne verbesserte Version, läuft zumindest bei meiner Testdatei sehr viel zuverlässiger, kannst ja nochmal testen.
Sub AuffuellenT()
Dim lngI As Long, lngN As Long
Dim rngFind As Range
Application.ScreenUpdating = False
lngI = 2
lngN = 0
With ActiveSheet
Do
If Trim(.Cells(lngI, 1).Text) <> Trim(.Cells(lngI, 3).Text) And _
.Cells(lngI, 1).Text <> "" And .Cells(lngI, 3).Text <> "" Then
Set rngFind = Range("C1:C" & .UsedRange.Rows.Count).Find(Trim(.Cells(lngI, 1)), LookIn:=xlValues)
If rngFind Is Nothing Then
Set rngFind = Range("A1:A" & .UsedRange.Rows.Count).Find(Trim(.Cells(lngI, 3)), LookIn:=xlValues)
If Not rngFind Is Nothing Then
.Range("C" & lngI & ":D" & .UsedRange.Rows.Count).Copy Destination:=.Range("C" & rngFind.Row)
.Range("C" & lngI & ":D" & rngFind.Row - 1).ClearContents
lngN = lngN + 1
Else
.Range("C" & lngI & ":D" & .UsedRange.Rows.Count).Copy Destination:=.Range("C" & lngI + 1)
.Range("C" & lngI & ":D" & lngI).ClearContents
lngN = lngN + 1
End If
Else
Set rngFind = Range("C1:C" & .UsedRange.Rows.Count).Find(Trim(.Cells(lngI, 1)), LookIn:=xlValues)
If Not rngFind Is Nothing Then
.Range("A" & lngI & ":B" & .UsedRange.Rows.Count).Copy Destination:=.Range("A" & rngFind.Row)
.Range("A" & lngI & ":B" & rngFind.Row - 1).ClearContents
lngN = lngN + 1
End If
End If
End If
lngI = lngI + 1
Loop Until lngI > .UsedRange.Rows.Count
MsgBox "Fertig ! Es wurden " & lngN & " Aktionen ausgeführt !", vbInformation
End With
Application.ScreenUpdating = True
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !