AW: ein Versuch
16.10.2008 08:45:16
Karen
Hallo David,
dieses ist das wohl relevante Makro:
Sub Daten_übertragen()
'Screening deaktivieren
'Application.ScreenUpdating = False
Dim rSuche As Range, rFinde As Range, i As Long
If IIf(IsEmpty(Sheets("Rohdaten").Cells(Rows.Count, 4)), Sheets("Rohdaten").Cells(Rows.Count, 4) _
_
.End(xlUp).Row, Rows.Count) > 7 Then
Set rFinde = Sheets("Terminierung").Range("A:A")
For i = 7 To IIf(IsEmpty(Sheets("Rohdaten").Cells(Rows.Count, 4)), Sheets("Rohdaten").Cells( _
_
Rows.Count, 4).End(xlUp).Row, Rows.Count)
Set rSuche = rFinde.Find(what:=Sheets("Rohdaten").Cells(i, 4), LookAT:=xlWhole, LookIn:= _
_
xlValues)
If Not rSuche Is Nothing Then
MsgBox rSuche
With Sheets("Rohdaten")
Cells(rSuche.Row, 1) = .Cells(i, 4)
Cells(rSuche.Row, 2) = .Cells(i, 5)
Cells(rSuche.Row, 3) = .Cells(i, 6)
Cells(rSuche.Row, 4) = .Cells(i, 8)
Cells(rSuche.Row, 5) = .Cells(i, 11)
End With
Else
With Sheets("Rohdaten")
Cells(65536, 1).End(xlUp).Offset(1, 0) = .Cells(i, 4)
Cells(65536, 2).End(xlUp).Offset(1, 0) = .Cells(i, 5)
Cells(65536, 3).End(xlUp).Offset(1, 0) = .Cells(i, 6)
Cells(65536, 4).End(xlUp).Offset(1, 0) = .Cells(i, 8)
Cells(65536, 5).End(xlUp).Offset(1, 0) = .Cells(i, 11)
End With
End If
Next i
End If
For i = 7 To IIf(IsEmpty(Sheets("Terminierung").Cells(Rows.Count, 1)), Sheets("Terminierung"). _
_
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
Set rFinde = Sheets("Rohdaten").Range("D:D")
Set rSuche = rFinde.Find(what:=Sheets("Terminierung").Cells(i, 1), LookAT:=xlWhole, LookIn:= _
_
xlValues)
If rSuche Is Nothing Then
Sheets("Terminierung").Range("B" & i & ":E" & i).ClearContents
End If
Next i
Set rSuche = Nothing
Set rFinde = Nothing
'Application.ScreenUpdating = True
End Sub
Hast Du eine Idee?
Viele Grüße
Karen