Makro steigt aus

Hallo liebe Leute,
ich habe folgendes Problem: über ein mit dem Recorder aufgezeichnetes Makro lasse ich den Wert einer Zelle in der gesammten Arbeitsmappe suchen und dann mit einigen anderen Werten aus der Zeile weiterarbeiten. Das funktioniert auch, solange es diesen Wert in der Arbeitsmappe nochmal gibt. Gibt es ihn nicht, steigt mir das Makro mit einer Fehlermeldung aus. Es soll aber in der Form weiterlaufen, dass es in die Zelle zurückgeht, in der es gestartet ist. Muß wohl irgendwie mit if-then-else funktionieren, kriege es aber einfach nicht hin. Habe unten einen Teil des Makros aufgeführt, irgendwo da müsste wohl die Lösung eingebaut werden.
Schon mal vielen Dank für eure Bemühungen
Sheets(1).Select
Cells.Find(What:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets(2).Select
Cells.FindNext(After:=ActiveCell).Activate
Sheets(1).Select
ActiveCell.Offset(0, -18).Range("A1:E1").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Selection.Copy
Sheets(2).Select
ActiveCell.Offset(0, -18).Range("A1").Select

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub KlausBergmann() Dim rngC1 As Range, rngC2 As Range Dim rngSuchbereich As Range Set rngSuchbereich = Sheets(2).Cells Sheets(1).Select For Each rngC1 In Range(ActiveCell, ActiveCell.Offset(1, 0)) Set rngC2 = rngSuchbereich.Find(rngC1, , , xlWhole) If Not rngC2 Is Nothing Then 'wenn gefunden, Kopieren von Spalte A bis E aus Suchwertzeile Sheets(1).Range(Cells(rngC1.Row, 1), Cells(rngC1.Row, 5)).Copy _ Destination:=Sheets(2).Range("A" & rngC2.Row) End If Next rngC1 End Sub

Sub test() Dim C As Range On Error Resume Next Set C = Sheets(2).UsedRange.Find(What:=ActiveCell.Value, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False) If Not C Is Nothing Then 'Treffer, machwas With Sheets(1).Range("A" & ActiveCell.Row & ": E" & ActiveCell.Row) .Interior.ColorIndex = 6 Sheets(2).Range("A" & C.Row & ": E" & C.Row).Interior.ColorIndex = .Interior.ColorIndex Sheets(2).Range("A" & C.Row & ": E" & C.Row).Value = .Value End With Application.Goto C, True Else ActiveCell.Offset(1, 0).Activate End If On Error GoTo 0 End Sub

Hallo Gerd,
Entschuldigung! das mit dem Gruß ist mir im Eifer des Gefechts dadurch gegangen.
Dein Vorschlag funktioniert für das geschilderte Problem einwandfrei. Ich habe ihn etwas erweitert, funktioniert bis auf folgendes super: bei der Übertragung des Wertes aus "X" bis "Y" werden die Werte vertauscht "X" steht in "Y" und umgekehrt - auch das Format stimmt nicht.
Hast Du oder möglicherweise jemand anderes eine Idee?
Ich habe die geänderte Variante unten aufgeführt
Schon mal vielen Dank und freundliche Grüsse


Sub test()
Dim C As Range
On Error Resume Next
Set C = Sheets(2).UsedRange.Find(What:=ActiveCell.Value, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not C Is Nothing Then
'Treffer, machwas
With Sheets(1).Range("A" & ActiveCell.Row & ": E" & ActiveCell.Row)
.Interior.ColorIndex = 6
Sheets(2).Range("A" & C.Row & ": E" & C.Row).Interior.ColorIndex = .Interior.ColorIndex
Sheets(2).Range("A" & C.Row & ": E" & C.Row).Value = .Value
End With
Application.Goto Sheets(1), True
' bis hier alles super
With Sheets(1).Range("X" & ActiveCell.Row & ": Y" & ActiveCell.Row)
.Interior.ColorIndex = 6
Sheets(2).Range("X" & C.Row & ": Y" & C.Row).Interior.ColorIndex = .Interior.ColorIndex
Sheets(2).Range("X" & C.Row & ": Y" & C.Row).Value = .Value
End With
Application.Goto Sheets(1), True
ActiveCell.Offset(1, 0).Activate
Else
ActiveCell.Offset(1, 0).Activate
End If
On Error GoTo 0
End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread