Werte suchen und übertragen

Hallo VBA'ler,

vielleicht kann mir jemand bei folgendem Problem helfen:

1. Ich habe ein Sheet (Basiswerte), das folgendes Aussehen hat (die Zahlen sind irgendwelche Basiswerte):

Tierart_Bas1__Bas2__Bas3
Hund____200___350___445
Katze____345___420___599
Maus____444__ 588___600
...usw.

2. Ich habe ein weiteres Sheet (Eingabe), in dem Eingaben gemacht werden:

Tierart Gewicht Ergebnis(Basiswert x Gewicht)
Hund________23_______(leer)
Maus________0,4______(leer)

3. Nun möchte ich folgendes erreichen:

Beim Klick in die leere Zelle(z.B. Zeile1) 'Ergebnis' soll folgendes passieren:
- Im Sheet Basiswerte soll nach dem Eintrag 'Hund' gesucht werden.
- Die entsprechenden Basiswerte sollen nun in ein drittes Sheet (Rechnen) gestellt werden und zwar in folgender Form:

Basiswert__Gewicht__Ergebnis(Basiswert x Gewicht)
200_________23_________4600
350_________23_________8050 ... hier wird später weitergerechnet
445_________23_________10235

Das ganze ist für mich zu komplex. Es wäre schon Klasse, wenn mir jemand helfen könnte.

Gruss Toni

P.S. Beachtet der Editor nicht mehrere Leerzeichen oder Tabs?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Toni,

mit Alt+F11 in die VBA-Umgebung wechseln, links oben im Projektfenster die Tabelle "Eingabe" doppelklicken und dann im rechten Codefenster diesen Code: (Dieser Code funktioniert aber nur, wenn deine Daten jeweils in Spalte A anfangen !!!)


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Suchbegriff As String, Trefferzelle As Range, i As Integer
Application.ScreenUpdating = False
If Target.Column = 3 And Target.Row <> 1 Then
Suchbegriff = Cells(Target.Row, 1)
With Sheets("Basiswerte")
.Activate
Set Trefferzelle = .Columns(1).Find(What:=Suchbegriff, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False)
Sheets("Ergebnis").Range("a2:b4").ClearContents
For i = 2 To 4
.Cells(Trefferzelle.Row, i).Copy Sheets("Ergebnis").Cells(i, 1)
Cells(Target.Row, 2).Copy Sheets("Ergebnis").Cells(i, 2)
Next i
End With
Sheets("Ergebnis").Activate
End If
Application.ScreenUpdating = False
End Sub

Oder die Beispieldatei studieren: https://www.herber.de/bbs/user/2050.xls

Bitte die Datei abspeichern und dann öffnen, in meinem Browserfenster funktionierte das direkte Öffnen nicht richtig !

Gruß Klaus

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte suchen und übertragen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread