Office: (Office 2010) Wert suchen zugehörige Daten ausgeben mit VBA

Kabelmann · 11. Mai 2014

Schönen guten Abend.

Ich habe das Internet und dieses Forum schon etwas durchforstet nach einer Lösung für mein Problem, leider wurde ich doch nicht fündig und hoffe, dass mir hier geholfen werden kann. Gleich einmal vorweg ich habe noch nicht wirklich Erfahrung mit VBA, versuche momentan es mir etwas anzueignen.

Sache ist folgende:
Ich möchte Messwerte eingeben und dann werden diese Werte in einer bestimmten Spalte einer Tabelle gesucht. Wenn der Wert gefunden wurde soll mir der Inhalt der ersten und zweiten Spalte (in der Zeile in der der Wert gefunden wurde) dieser Tabelle zurück ausgegeben werden. Hinzu kommt das die Werte nicht unbedingt exakt übereinstimmen werden. Sie sollen den Wert suchen der den eingegebenen am ehesten Entspricht.
Ich habe schon eine Eingabemaske erstellt in der man Werte eingeben kann. Diese werden dann auch in Zellen geschrieben und als Variablen gespeichert. Soweit so gut jedoch weis ich jetzt nicht weiter.

Da ich mir gerade nicht sicher bin ob ich das Verständlich ausgedrückt habe nochmal etwas Anschaulicher:

Wert1 auf Tabelle 1 ist der Wert den man eingibt
Wert1 soll auf Tabelle 2 in Spalte (D41: D88) gesucht werden mit einer Toleranz von +- 0,2
Wenn der Wert gefunden wurde soll in dieser Zeile der Inhalt der Spalte 1 und 2 in bestimmte Zellen auf Tabelle 1 kopiert werden

Ich hoffe ich konnte das Problem anschaulich rüberbringen und das ihr mir helfen könnt dabei *Smilie

Wünsche noch einen schöen Tag.

:)

Mc Santa · 13. Mai 2014

Hallo,

bitte lade hier im Forum eine Beispielmappe hoch.
Außerdem brauche ich eine präzise Angabe, was "bestimmte Zellen auf Tabelle 1" sind *wink.gif*

Ansonsten habe ich das Problem soweit verstanden, das sollte machbar sein *Smilie
VG

Kabelmann · 13. Mai 2014

Guten Morgen,

schon einmal danke für die schnelle Antwort. *Smilie
Habe eine Beispieldatei angehängt. Mit bestimmte Zelle auf Tabelle 1 meinte ich einfach nur die wo ich es haben will wie in der Beispieldatei zum Beispiel Zellen F5: G9. Da sind jetzt mehrere Werte die man Eingibt und nach denen gesucht werden soll damit man genauer sagen kann ob es jetzt Produkt P in der Kombination mit G ist. Habe ich jetzt vorher nicht weiter erwähnt da ich das dann ja sicher rekonstruieren könnte für die anderen Werte *Smilie
Wäre super wenn das klappt.

mfg

Mc Santa · 13. Mai 2014

Hallo,

Folgender Code durchsucht für dich die Tabelle2 nach TEGB mit einer Toleranz von 0,2. Wird ein Eintrag gefunden, werden die Werte P und G ausgelesen und in Tabelle1 übertragen.

Code:

Sub mySearch()
Dim r As Range, rInput As Range, rSrc As Range, rMatch As Range, rOutP As Range, rOutG As Range
Dim dTol As Double

Set rInput = ThisWorkbook.Sheets("Tabelle1").Range("C5")
Set rSrc = ThisWorkbook.Sheets("Tabelle2").Range("C14:C88")
Set rOutP = ThisWorkbook.Sheets("Tabelle1").Range("F5")
Set rOutG = ThisWorkbook.Sheets("Tabelle1").Range("G5")
dTol = 0.2

If Not IsNumeric(rInput.Value) Then
MsgBox "Fehler bei Eingabe"
Exit Sub
End If

Set rMatch = Nothing
For Each r In rSrc
If IsNumeric(r) Then
If rMatch Is Nothing Then
If Abs(rInput.Value - r.Value) < dTol Then
Set rMatch = r
End If
ElseIf Abs(rInput.Value - r.Value) < dTol And Abs(rInput.Value - r.Value) < Abs(rInput.Value - rMatch.Value) Then
Set rMatch = r
End If
End If
Next r

If Not rMatch Is Nothing Then
rOutG = rMatch.Offset(, -1)
rOutP = rMatch.Offset(, -2).MergeArea.Cells(1, 1)
Else
rOutG = "n/a"
rOutP = "n/a"
End If
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Leider hat bei mir deine Userform nicht funktioniert, daher ist der Code jetzt nur als Sub. Ehrlich gesagt würde ich die Userform auch einfach weglassen: Der Nutzer gibt seine Daten in C5-C9 ein (oder auch nicht) und klickt auf einen Button "Start", dann werden die Ergebnisse abgefragt. Das reicht in meinen Augen völlig, aber ist nur meine Meinung *Smilie

Freue mich über Feedback und Anmerkungen. Fragen gerne!
VG

Mc Santa · 14. Mai 2014

Hab mal fertig gebastelt:
Code:

Option Explicit

Sub mySearch()
Dim r As Range, rMatch As Range, rInput(0 To 4) As Range, rSrc(0 To 4) As Range, rOutP(0 To 4) As Range, rOutG(0 To 4) As Range
Dim dTol As Double, i As Integer

dTol = 0.2

With ThisWorkbook.Sheets("Tabelle1")
Set rInput(0) = .Range("C5")
Set rInput(1) = .Range("C6")
Set rInput(2) = .Range("C7")
Set rInput(3) = .Range("C8")
Set rInput(4) = .Range("C9")

Set rOutP(0) = .Range("F5")
Set rOutP(1) = .Range("F6")
Set rOutP(2) = .Range("F7")
Set rOutP(3) = .Range("F8")
Set rOutP(4) = .Range("F9")

Set rOutG(0) = .Range("G5")
Set rOutG(1) = .Range("G6")
Set rOutG(2) = .Range("G7")
Set rOutG(3) = .Range("G8")
Set rOutG(4) = .Range("G9")
End With

With ThisWorkbook.Sheets("Tabelle2")
Set rSrc(0) = .Range("C41:C88")
Set rSrc(1) = .Range("D41:D88")
Set rSrc(2) = .Range("E41:E88")
Set rSrc(3) = .Range("F41:F88")
Set rSrc(4) = .Range("G41:G88")
End With

For i = LBound(rOutP) To UBound(rOutP)
rOutP(i).Clear
rOutG(i).Clear
Next i

For i = LBound(rInput) To UBound(rInput)
If Not IsNumeric(rInput(i).Value) Then
GoTo Next_Value
End If

Set rMatch = Nothing
For Each r In rSrc(i)
If IsNumeric(r) Then
If rMatch Is Nothing Then
If Abs(rInput(i).Value - r.Value) < dTol Then
Set rMatch = r
End If
ElseIf Abs(rInput(i).Value - r.Value) < dTol And Abs(rInput(0).Value - r.Value) < Abs(rInput(i).Value - rMatch.Value) Then
Set rMatch = r
End If
End If
Next r

If Not rMatch Is Nothing Then
rOutG(i) = rMatch.Offset(, -1 - i)
rOutP(i) = rMatch.Offset(, -2 - i).MergeArea.Cells(1, 1)
Else
rOutG(i) = "n/a"
rOutP(i) = "n/a"
End If

Next_Value:
Next i
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Viel Spaß damit *Smilie

Kabelmann · 14. Mai 2014

Vielen Dank der Code funktioniert wunderbar. Da hast du recht was die Eingabe der Werte angeht. Das war nur das erste was ich bisher mit VBA mal gemacht habe und deshalb hab ich das da noch drin gehabt. *Smilie

Vielen dank für die schnelle Hilfe *Smilie

Edit: Oh gerade gesehen du es schon fertig hast *Smilie gleich mal testen.
Edit2: Klappt super mit den Code von dir. Meine Fragen die ich vorher hatte haben sich damit auch erledigt. Vielen dank *Smilie

Office: (Office 2010) Wert suchen zugehörige Daten ausgeben mit VBA

Wert suchen zugehörige Daten ausgeben mit VBA

Wert suchen zugehörige Daten ausgeben mit VBA

Wert suchen zugehörige Daten ausgeben mit VBA

Wert suchen zugehörige Daten ausgeben mit VBA - Similar Threads - Wert zugehörige Daten

Adressen in eine Zelle bei Übereinstimmung eindeutiger Werte einer anderen Spalte

Name in Datenbereich suchen und zugehörigen Wert in der Zeile in einer neuen Tabelle ausgeben

Werte in Stammdaten suchen und zugehörige Zellen in Tabelle 2 kopieren

FreiText in SPalte mehrfach finden, zugehöriger Wert aus anderer Spalte ausgeben

Produktkalkulation - Suche Wort in Bereich XY, gebe zugehörigen Wert aus

Probleme mit Dropdownfeld und zugehörigen Werten

Aus Matrix MAX-Wert + zugehöriger Index GELÖST