Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 10:38:52
Bedingte Formatierung per VBA / MaxPoint
25.04.2024 10:30:04
Suche mit MINWENNS und Rückgabe mehrerer Werte
25.04.2024 09:47:49
Daten aus mehreren Dateien untereinander importieren
25.04.2024 09:31:31
Bild "In Zelle platzieren"
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1416to1420
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1416to1420
1416to1420
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

kleinster Wert übertragen

kleinster Wert übertragen
25.03.2015 09:33:29
Gregor
Hallo zusammen
Ich will mit vba von einem Quellblatt in ein Zielblatt den kleineren (kleinsten) Wert übertragen. Siehe Musterdatei
https://www.herber.de/bbs/user/96620.xlsx
In Blatt Ziel soll der kleinste "Wert" von den "Zahlen" 1, 2, 3 und 4 vom Blatt Quelle übertragen werden. Die "Zahlen" innerhalb der "Muster" sind unterschiedlich und können von 1 bis 15 zählen, dieselbe "Zahl" kann in Blatt Quelle innerhalb "Muster" nur einmal oder aber zweimal vorkommen.
Wie könnte so ein Code aussehen?
Vielen Dank und Gruss
Gregor

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

Betreff
Datum
Anwender
Anzeige
mit Scripting.Dictionary
25.03.2015 11:07:51
Erich
Hi Gregor,
das hier sollte recht flott gehen: 

Option Explicit
Sub Dict_Min()
Dim myDict As Object, arW, zz As Long, strK As String
Dim arrK, arE()
Set myDict = CreateObject("Scripting.Dictionary")
With Sheets("Quelle")
arW = .Cells(2, 1).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row - 1, 3)
End With
For zz = 1 To UBound(arW)
If arW(zz, 1) = "" Then arW(zz, 1) = arW(zz - 1, 1)
strK = arW(zz, 1) & "|" & arW(zz, 2)
If myDict.Exists(strK) Then
' neuer Wert ist kleiner
If myDict(strK) > arW(zz, 3) Then myDict(strK) = arW(zz, 3)
Else
myDict(strK) = arW(zz, 3)
End If
Next zz
With Sheets("Ziel")
arW = .Cells(2, 1).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row - 1, 2)
ReDim arE(1 To UBound(arW), 0)
For zz = 1 To UBound(arW)
If arW(zz, 1) = "" Then arW(zz, 1) = arW(zz - 1, 1)
strK = arW(zz, 1) & "|" & arW(zz, 2)
If myDict.Exists(strK) Then
arE(zz, 0) = myDict(strK)
Else
arE(zz, 0) = "### fehlt ###"
End If
Next zz
.Cells(2, 3).Resize(UBound(arW)) = arE
End With
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Anzeige
AW: mit Scripting.Dictionary
25.03.2015 11:29:37
Gregor
Hoi Erich
Das geht tatsächlich flott und funktioniert wie gewünscht, vielen Dank. Ich verstehe auf den ersten Blick fast gar nichts, werde das aber noch genauer anschauen.
Gruss Gregor

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige