Anzeige
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 Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

kleinster Wert übertragen

Forumthread: 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

Anzeige

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)

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