Hallo,
ich habe in das Makro eine Zellauswahl eingefügt, von wo aus die Werte eingetragen werden. Es erfolgt hier aber keine Fehlerabfrage, wenn auf Abbrechen geklickt oder keine Zellladresse eingetragen wird!
Code:
Sub prcX2()
Dim rngSuche As Range, rngAusgabe As Range
Dim lngLastRow As Long, lngC As Long
Dim strArt As String, strAdresse As String
Set rngAusgabe = Application.InputBox("Von welcher Zelle aus soll gestartet werden?", "Zellauswahl", Type:=8)
With Worksheets("Tabelle2")
'die Daten aus dem Auswertebereich löschen
On Error Resume Next
rngAusgabe.Resize(rngAusgabe.End(xlDown).Row, 7).ClearContents
On Error Goto 0
' .Cells(2, 7).Resize(.Cells(2, 7).End(xlDown).Row - 1, 6).ClearContents
'Schleife für den Suchwert und -/+ 10
For lngC = -10 To 10
'der Wert wird im Zellbereich E5:N16 gesucht
Set rngSuche = Worksheets("Tabelle1").Range("E5:N16").Find(What:=.Range("B6") + lngC, LookIn:=xlValues, LookAt:=xlWhole)
'wenn es einen Treffer gibt....
If Not rngSuche Is Nothing Then
'...wird die Adresse des ersten Treffers in einer Variablen gespeichert....
strAdresse = rngSuche.Address
Do
If Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value = .Cells(6, 4).Value And _
(.Cells(6, 3).Value = "X" And rngSuche.Column < 10 Or .Cells(6, 3).Value = "Y" And rngSuche.Column > 9) Then
'... und die erste freie Zelle im Auswertebereich gesucht....
If Not IsEmpty(rngAusgabe) Then lngLastRow = .Cells(.Rows.Count, rngAusgabe.Column).End(xlUp).Row + 1 Else lngLastRow = rngAusgabe.Row
' ... und in die Tabelle eingetragen
.Cells(lngLastRow, rngAusgabe.Column).Value = rngSuche.Value
.Cells(lngLastRow, rngAusgabe.Column).Offset(, 1).Value = IIf(rngSuche.Column < 10, "X", "Y")
.Cells(lngLastRow, rngAusgabe.Column).Offset(, 2).Value = Worksheets("Tabelle1").Cells(4, rngSuche.Column).Value
.Cells(lngLastRow, rngAusgabe.Column).Offset(, 3).Value = "Option" & IIf(rngSuche.Row < 11, "1", "2")
Select Case rngSuche.Row
Case 5 To 7, 11 To 13
strArt = "Art1"
Case Else
strArt = "Art2"
End Select
.Cells(lngLastRow, rngAusgabe.Column).Offset(, 4).Value = strArt
' .Cells(lngLastRow, 12).Value = .Cells(rngSuche.Row, 4).Value
'Suche nach einen weiteren Treffer
End If
Set rngSuche = Worksheets("Tabelle1").Range("E5:N16").FindNext(rngSuche)
'und wiederhole es solange, bis der erste Treffer wieder gefunden wird
Loop While rngSuche.Address <> strAdresse
End If
Next lngC
End With
End Sub
Nachtrag: Fehlernotbehandlung eingebaut.
Doppelte Werte suchen und die dan in die neue Tabelle automatisch einfügen
