Bestellung vervollständigen

Sub FindenUndKopieren() Dim rng As Range Dim loDeinWert As String Dim sFirstAdress As String 'gesuchter Wert wert = "Artikel Nr" Set rng = Worksheets("Bestellung").UsedRange.Find(wert) If rng Is Nothing Then MsgBox "Wert " & loDeinWert & " nicht gefunden!" Else sfirstaddress = rng.Address Do rng.EntireRow.Copy Worksheets("Tabelle1").Cells(Rows.Count, "A").End(xlUp) _ .Offset(1, 0).PasteSpecial Paste:=xlPasteAll Set rng = Worksheets("Bestellung").UsedRange.FindNext(rng) Loop While Not rng Is Nothing And rng.Address sfirstaddress End If End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Lea,
hier ein Beispiel. Das Makro klappert nach einander die Zellen um die Fundstelle ab,
wird eine Zahl gefunden, dann wird der Wert in Tabelle1 ausgegeben.
Dabei sollte die Zelle in der der nummerische Wert am häufigsten zu finden ist in der 1. If-Zeile stehen.
Gruß
Franz

Sub FindenUndKopieren_2()
Dim rng As Range
Dim loDeinWert As String
Dim sFirstAdress As String
Dim varGefunden
'gesuchter Wert
loDeinWert = "Menge"
Set rng = Worksheets("Bestellung").UsedRange.Find(loDeinWert)
If rng Is Nothing Then
MsgBox "Wert " & loDeinWert & " nicht gefunden!"
Else
sFirstAdress = rng.Address
Do
varGefunden = ""
'Zellen um Fundstelle absuchen
If fncAnalyseZahl(rng.Offset(1, 0).Text, varGefunden) = True Then
'links neben der Fundstelle
ElseIf fncAnalyseZahl(rng.Offset(0, 1).Text, varGefunden) = True Then
'Rechts neben der Fundstelle
ElseIf fncAnalyseZahl(rng.Offset(1, 1).Text, varGefunden) = True Then
'Rechts unterhalb der Fundstelle
ElseIf fncAnalyseZahl(rng.Offset(-1, 0).Text, varGefunden) = True Then
'oberhalb der Fundstelle
ElseIf fncAnalyseZahl(rng.Offset(-2, 0).Text, varGefunden) = True Then
'2 Zeilen oberhalb der Fundstelle
'.... usw.
End If
If varGefunden  "" Then
With Worksheets("Tabelle1").Cells(Rows.Count, "B").End(xlUp)
.Offset(1, 0).Value = varGefunden
.Offset(1, 1).Value = "Menge in " & rng.Address 'Testzeile
End With
Else
MsgBox "um Zelle " & rng.Address(False, False, xlA1) & " keine Zahl gefunden"
End If
Set rng = Worksheets("Bestellung").UsedRange.FindNext(rng)
Loop While Not rng Is Nothing And rng.Address  sFirstAdress
End If
End Sub
Public Function fncAnalyseZahl(strText As String, varErgebnis) As Boolean
Dim strWert As String
varErgebnis = ""
strWert = Trim(strText)
If strWert = "" Then
ElseIf IsNumeric(strWert) Then
varErgebnis = CDbl(strWert)
fncAnalyseZahl = True
End If
End Function

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread