Beiträge zum Thread: Makro berücksichtigt nicht alle Zeilen

Moin Christian, :-)

... der Wert ist ja auch 0,1. ;-)


Und du fragst dann: ;-)

If valF < 0.1 And valF > 0 Then

Nimm: ;-)

If valF <= 0.1 And valF > 0 Then

Servus
Case

Hallo case, erstmal danke. trifft das nicht auch auf die anderen zeilen zu, in denen 10% steht, die werden doch auch übernommen.

Gruß
Christian

Moin Christian, :-)

... - da hängen wir wieder an der "Floating-Point-Ungenauigkeit": ;-)

Mit

Debug.Print i, Cells(i, "F").Value2, valF, valF < 0.1

getestet: ;-)



Und dann mit

Debug.Print i, Format$(valF, "0.00000000000000000000"), valF - 0.1, valF < 0.1

auch: ;-)



Teste mit Runden z. B.

If valF > 0 And Round(valF, 10) <= 0.1 Then

so. ;-)

Servus
Case

Hallo case,

Ich vermute einen rundungsfehler beim makro, dass die prozentwerte berechnet, werde das morgen prüfen und melde mich dann wieder.

Gruß
Christian

oder die Zahlen in den Feldern *100 nehmen und dann erst prüfen, erhöht die Genauigkeit (Float Fehler umgangen)

0,1 wird dann 10 entsprechend anpassen

Hallo Case, hallo Marc,

ich habe im Laufe des Tages versucht, Case' Erklärung zu verstehen und das mit dem Floating Point habe ich zum ersten mal gehört. Also wenn ich euch richtig verstehe sieht der Wert wie 0,1 oder eben 10% aus, aber intern wird er als ein minimal größerer oder kleinerer wert gespeichert. Es kann also sein dass der Code auf <0,1 prüft aber in der Zelle ein Wert steh der etwas größer als 0,1 ist und das geht schief. Deshalb schlägt Case vor, auf Round(valF, 10) also 10 Nachkommastellen zu runden. Marc schlägt vor, mit 100 zu multiplizieren valF = valF * 100 und zu prüfen If valF <= 10 And valF > 0 Then.

Ich hoffe, ich habe es verstanden.
Aber ich habe mir gedacht, trotzdem wo kommen diese Unstimmigkeiten her.

Die Prozentrechnung ist eigentlich simpel, Rang(E1)/Anzahl(E:E) ergibt mit 2 Nachkommastellen aufgerundet den Prozentwert. (Hierbei bedenken, dass ich nur 10% des Blatts Codes geschickt habe wegend der Größenbeschränkung, wenn alle Daten da wären, würde die Rechnung passen).

Habe mir dann die Rechnung in der Originaldatei angeschaut. =RANG(E37346;E1:E45000;0) ergibt 3279, =ANZAHL(E:E) ergibt 32786, somit der Quotient 0,1000122 was >0,1 ist und damit auf 2 Stellen aufgerundet eigentlich 11% sein müsste.

Und damit meine Vermutung, dass 0,1000122 der intern gespeicherte, als 10% angezeigte Wert ist, der nicht ins Blatt AZN übernommen wurde weil >0,1.

Aber dann zu meiner Frage, das hier ist das Makro, dass die Prozentzahlen in der Originaldatei berechnet hat, warum hat es 0,1000122 zu 10% abgerundet?

Public Sub BerechneCodesRanking(ws As Worksheet)

    Dim Eingabearray As Variant

    Dim DatumArray() As Double

    Dim Ausgabearray() As Variant

    Dim RangDict As Object

    Dim GesamtZeilen As Long

    Dim i As Long, j As Long

    Dim AnzahlGueltigerDaten As Long

    Dim LetztesDatum As Double



    ' Daten aus Spalte E einlesen

    GesamtZeilen = ws.Cells(ws.Rows.count, "E").End(xlUp).row

    Eingabearray = ws.Range("E1:E" & GesamtZeilen).Value



    ' Nur gültige Datumswerte zählen

    AnzahlGueltigerDaten = 0

    For i = 1 To GesamtZeilen

        If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) <> "" Then

            AnzahlGueltigerDaten = AnzahlGueltigerDaten + 1

        End If

    Next i



    If AnzahlGueltigerDaten = 0 Then Exit Sub



    ' DatumArray dimensionieren

    ReDim DatumArray(1 To AnzahlGueltigerDaten)

    j = 1

    For i = 1 To GesamtZeilen

        If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) <> "" Then

            DatumArray(j) = DatumZuSortierwert(Eingabearray(i, 1))

            j = j + 1

        End If

    Next i



    ' Absteigend sortieren

    QuickSortDatum DatumArray, 1, AnzahlGueltigerDaten



    ' RangDictionary erstellen

    Set RangDict = CreateObject("Scripting.Dictionary")

    For i = 1 To AnzahlGueltigerDaten

        If i = 1 Or DatumArray(i) <> LetztesDatum Then

            RangDict(CStr(DatumArray(i))) = i

        End If

        LetztesDatum = DatumArray(i)

    Next i



    ' Ausgabe vorbereiten

    ReDim Ausgabearray(1 To GesamtZeilen, 1 To 1)

    For i = 1 To GesamtZeilen

        If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) <> "" Then

            Ausgabearray(i, 1) = WorksheetFunction.RoundUp( _

                RangDict(CStr(DatumZuSortierwert(Eingabearray(i, 1)))) / AnzahlGueltigerDaten, 2)

        End If

    Next i



    ' Ergebnisse in Spalte F schreiben

    ws.Range("F1").Resize(GesamtZeilen, 1).Value = Ausgabearray

    ws.Range("F1").Resize(GesamtZeilen, 1).NumberFormat = "0%"

End Sub





Private Function DatumZuSortierwert(ByVal v As Variant) As Double

    Dim Teile() As String

    Dim Tag As Long, Monat As Long, jahr As Long



    ' Wenn Excel es als Datum erkennt

    If IsDate(v) Then

        jahr = Year(v)

        Monat = Month(v)

        Tag = Day(v)

        DatumZuSortierwert = jahr * 10000# + Monat * 100# + Tag

        Exit Function

    End If



    ' Wenn Text "dd.mm.yyyy"

    If InStr(v, ".") > 0 Then

        Teile = Split(v, ".")

        If UBound(Teile) = 2 Then

            Tag = val(Teile(0))

            Monat = val(Teile(1))

            jahr = val(Teile(2))

            DatumZuSortierwert = jahr * 10000# + Monat * 100# + Tag

            Exit Function

        End If

    End If



    ' Sonst 0 zurückgeben

    DatumZuSortierwert = 0

End Function



Private Sub QuickSortDatum(ByRef arr() As Double, ByVal IndexUnten As Long, ByVal IndexOben As Long)

    Dim PivotWert As Double

    Dim TempWert As Double

    Dim Links As Long

    Dim Rechts As Long



    Links = IndexUnten

    Rechts = IndexOben

    PivotWert = arr((IndexUnten + IndexOben) \ 2)



    Do While Links <= Rechts

        Do While arr(Links) > PivotWert

            Links = Links + 1

        Loop

        Do While arr(Rechts) < PivotWert

            Rechts = Rechts - 1

        Loop

        If Links <= Rechts Then

            TempWert = arr(Links)

            arr(Links) = arr(Rechts)

            arr(Rechts) = TempWert

            Links = Links + 1

            Rechts = Rechts - 1

        End If

    Loop



    If IndexUnten < Rechts Then QuickSortDatum arr, IndexUnten, Rechts

    If Links < IndexOben Then QuickSortDatum arr, Links, IndexOben

End Sub

Das Problem ist das 0,1 eine Float Zahl ist, also Kommazahl, und es kann vorkommen das 0,1 mal "falsch" gedeutet wird:

Das liegt daran, dass Computer Fließkommazahlen (Floating Point Numbers) intern binär speichern.

Das Problem: Viele Dezimalzahlen können im Binärsystem nicht exakt dargestellt werden – ähnlich wie man 1/3 im Dezimalsystem nicht exakt als endliche Zahl schreiben kann:

1/3 = 0,333333...
0,1 im Binärsystem = 0,00011001100110011...

Diese Darstellung muss irgendwann abgeschnitten werden. Dadurch wird statt exakt 0,1 etwas gespeichert wie:
0,10000000000000000555...

Dadurch wird Vergleich mal richtig mal falsch betrachtet.
Es gibt mehrere Wege dies zu umgehen. Ich selber Multipliziere dann mit 100 und mache daraus eine Int (Ganzzahl) damit ist alles weg, was hinter dem Komma kommt.

Cint(zahl *100)

oder du kannst auch auf eine oder 2 Stellen oder wie viele du exakt brauchst runden.
Round(zahl,2)

Alle Zahlen der 2er Potenz können exakt dar gestellt werden (z.B. 0,5 oder 0,25 oder 0,125) alle anderen Zahlen nicht.

Moin Christian, :-)

... "Gleitkommagymnastik" können die Bänder schon mal falsch gedehnt werden: ;-)
https://learn.microsoft.com/de-de/troubleshoot/microsoft-365-apps/excel/floating-point-arithmetic-inaccurate-result

Servus
Case

Hi

Wenn das Problem die Rechenungenaugkeit ist, dann probiere mal:

If valF < 0.105

Dann sollte alles übernommen werden, was dir in der Tabelle als 10% und kleiner angezeigt wird.

Gruß Daniel

Hallo daniel,

Erst am vielen Dank. Schau dir bitte mal meine Post von gestern abend an. Der Wert, der in diesem Fall zu 10% gerundet wurde ist 0,1000122 und hätte eigentlich zu 0,11 aufgerundet werden sollen da größer 0,1 und kleiner 0,11. Daher hatte ich gestern Abend das makro geschickt, das die %zahlen erstellt, weil es aus irgendeinem Grund abgerundet statt aufgerundet hat. Somit ist es korrekt dass die zeile nicht übernommen wurde weil der Wert >0,1 ist, die 10% sind falsch, es hätte eigentlich 11% lauten sollen.

Gruß
Christian

Hast du auch Daten, auf die man das Makro anwenden kann und bei denen das Problem auftritt?

Hallo Daniel, mein Problem ist, die %REchnung basiert auf dem vollständigen Blatt Codes mit 45000 Zeilen, wenn du verrrätst, wie ich dir das komplette Blatt zukommenlassen kann trotz der Größenberschränkung hier, schicke ich es dir gerne. (Als Zip mit größter Kompression und sämtliche Formatierungen entfernt immer noch 1,13 MB.)

Hallo Daniel,

hier sind die Daten, Makro liegt in der Mappe. Der Fall, über den wir die ganze Zeit reden ist Zeile 27157. Hier hätte das Makro 0,1000122 zu 0,11 aufrunden sollen, hat es aber zu 0,1 abgerundet.

Gruß
Christian
https://www.herber.de/bbs/user/180812.xlsm

Hallo Christian;


Ich denke mal so.

Sub SchreibeAZN_A_bis_C()



    Dim wsCodes As Worksheet, wsLeute As Worksheet, wsAZN As Worksheet

    Dim lastRow As Long, i As Long

    Dim arrCodes As Variant

    Dim nameMatch As Variant

    Dim codeVal As String, nameVal As Variant, dateVal As Variant

    Dim valF As Double

    Dim dictAZN As Object

    Dim key As Variant

    Dim arrOut() As Variant

    

    Set wsCodes = ThisWorkbook.Worksheets("Codes")

    Set wsLeute = ThisWorkbook.Worksheets("Leute")

    Set wsAZN = ThisWorkbook.Worksheets("AZN")

    Set dictAZN = CreateObject("Scripting.Dictionary")

    

    '--- Codes D:F einlesen ---

    lastRow = wsCodes.Cells(wsCodes.Rows.Count, "D").End(xlUp).Row

    If lastRow < 1 Then Exit Sub

    

    arrCodes = wsCodes.Range("D1:F" & lastRow).Value

    

    '--- AZN-Daten sammeln ---

    For i = 1 To UBound(arrCodes, 1)

        

        codeVal = Trim(CStr(arrCodes(i, 1))) 'Spalte D

        dateVal = arrCodes(i, 2)             'Spalte E

        

        If IsNumeric(arrCodes(i, 3)) Then    'Spalte F

            valF = CDbl(arrCodes(i, 3))

            

            If valF <= 0.1 And valF > 0 And codeVal <> "" Then

                

                If Not dictAZN.Exists(codeVal) Then

                    

                    nameMatch = Application.VLookup(codeVal, wsLeute.Range("B:C"), 2, False)

                    

                    If Not IsError(nameMatch) Then

                        nameVal = nameMatch

                    Else

                        nameVal = ""

                    End If

                    

                    dictAZN.Add codeVal, Array(nameVal, dateVal)

                    

                End If

                

            End If

        End If

        

    Next i

    

    '--- Ausgabe in AZN!A:C ---

    wsAZN.Range("A:C").ClearContents

    

    If dictAZN.Count > 0 Then

        

        ReDim arrOut(1 To dictAZN.Count, 1 To 3)

        

        i = 1

        For Each key In dictAZN.Keys

            arrOut(i, 1) = key

            arrOut(i, 2) = dictAZN(key)(0)

            arrOut(i, 3) = dictAZN(key)(1)

            i = i + 1

        Next key

        

        wsAZN.Range("A1").Resize(dictAZN.Count, 3).Value = arrOut

        

    End If



End Sub

Hallo Robert,

danke dir für den Code

Für mein konkretes Problem löst sie es aber leider nicht, weil der Fehler nicht im AZN‑Makro liegt, sondern schon vorher bei der Berechnung der Prozentwerte entsteht:

Der Wert, der später als 10 % angezeigt wurde, ist intern 0,1000122.
RoundUp(...,2) macht daraus 0,10, obwohl der Wert eigentlich auf 0,11 hätte gehen müssen.
Da der interne Wert aber größer als 0,1 ist, fällt die Zeile beim Vergleich korrekt raus.

Ich muss daher zuerst das Ursprungs‑Makro korrigieren, das die Prozentwerte erzeugt – danach funktioniert auch die AZN‑Auswertung wieder sauber.

Gruß
Christian

Dieser Code doch:
Zeilen ohne Namen können gelöscht werden.

Sub M_snb()

  sn = Tabelle1.Cells(1, 4).CurrentRegion

  sp = Tabelle2.Cells(1, 2).CurrentRegion

    

  With CreateObject("scripting.dictionary")

    For j = 1 To UBound(sp)

      .Item(sp(j, 1)) = sp(j, 2)

    Next



    For j = 1 To UBound(sn)

      If sn(j, 3) <= 0.1 Then

        sn(j, 3) = .Item(sn(j, 1))

        .Remove sn(j, 1)

     End If

   Next

 End With

    

 Tabelle3.Cells(1).Resize(UBound(sn), 3) = sn

End Sub

Hallo snb,

danke dir für den Vorschlag.
Ich habe inzwischen herausgefunden, dass das Problem nicht im AZN‑Makro liegt, sondern in den Prozentwerten selbst:

Der Wert, der später als 10 % angezeigt wurde, ist intern 0,1000122.
RoundUp(...,2) macht daraus 0,10, obwohl der Wert eigentlich auf 0,11 hätte gehen müssen.

Da der interne Wert aber größer als 0,1 ist, fällt die Zeile beim Vergleich korrekt raus.

Ich muss daher zuerst das Ursprungs‑Makro korrigieren, das die Prozentwerte erzeugt – danach funktioniert auch die AZN‑Auswertung wieder sauber.

Gruß
Christian

Aber dennoch wäre es vernünftig diesen Code genau zu betrachten und etwas davon zu lernen.

Die einzige Version, die ich gefunden habe und wirklich 11% ausgibt ist das hier:

Public Sub BerechneCodesRanking(ws As Worksheet)

    Dim GesamtZeilen As Long



    GesamtZeilen = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row



    ws.Range("F1:F" & GesamtZeilen).FormulaLocal = _

        "=AUFRUNDEN(RANG(E1;E$1:E$" & GesamtZeilen & ";0)/ANZAHL(E$1:E$" & GesamtZeilen & ");2)"



    ws.Range("F1:F" & GesamtZeilen).Value = ws.Range("F1:F" & GesamtZeilen).Value

    ws.Range("F1:F" & GesamtZeilen).NumberFormat = "0%"

End Sub

dauert aber so lange, dass ich am überlegen bin, diese Ungenauigkeit doch in Kauf zu nehmen.

Hi
Wenn es bei großen Datenmengen schnell gehen soll und du sowieso mit Makros arbeitet:
kopiere dir die Daten in ein neues Tabellenblatt und sortiere sie nach dem Datum. Dann ergibt sich der Rang aus der Zeilennummer - 1 (erste Zeile Überschrift)
will man bei gleichen Werten gleichen Rang, dann schreibt man eine Formel, die den Wert aus der darüber liegenden Zelle übernimmt, wenn der Wert gleich dem darüberliegenden Wert ist und neu berechnet, wenn der Wert sich ändert.

in dieser Sortierung kannst du dann auch einfach per VERGLEICH (Application.MATCH) ermitteln, in welcher Zeile die 10% überschritten werden und dann einfach die Zeilen ab Zeile 2 bis zu dieser kopieren.

das sollte sehr schnell sein und auch mit einfachen Programmiermethoden, die sich zum größten Teil auch mit dem Recorder aufzeichnen lassen (z.B. das Einfügen der Formeln) bewältigen lassen.

ja, das ist nicht so "sophisticated" wie Dictionary und Quicksort zu verwenden, aber es funktioniert und ist dabei nicht viel langsamer. Außerdem hast du besser die Kontrolle, was passiert, weil auch die Zwischenschritte in einem Tabelleblatt stattfinden, so dass du diese auch schrittweise ausführen und kontrollieren kannst, während mit Dictionary und Quicksort dann doch viel direkt in VBA passiert, was du nicht anschauen kannst, sondern dir vorstellen musst.

Gruß Daniel

Hallo Daniel,

an sich eine nicht schlechte Idee. Die Mappe insgesamt ist nur so komplex, dass es einiges zu ändern gibt in den Makros, wenn die Prozentzahlen plötzlich woanders stehen. Aber hab dir deine gewünschten Komplettdaten geschickt.

Gruß
Christian

Dein Makro kann die auf dem Zwischenblatt erzeugten Daten ja wieder in die Originaltabelle an die gewünschte Stelle zurückschreiben.

hast recht und genau genommen kann ich es ja auch im selben Blatt machen. Aber wenn die doch noch eine Lösung, wie man das bisherige Makro ändern könnte, hab ich dir ja geschickt, einfällt nehme ich die auch gerne

Es gibt zig stellen in der Mappe, wo die Frage <=10% oder >10% entscheidend ist. An allen Stellen scheinen die Makros diese Stelle korrekt als >0,1 behandelt zu haben. Das einzige Problem ist also wirklich die Anzeige der Prozentzahl.

aber mal nur so eine Idee, ob sich das umsetzen lässt muss ich leider euch überlassen

aber meine Idee ist jetzt:

Tatsache 0,1000122 wird trotz Roundup zu 0,10 abgerundet.

kann das Makro nicht prüfen ob RoundUp und RoundDown dieser Zahl identisch ist und ungleich der Zahl, wenn ja 0,01 addieren?

Beispiel 3279/32786 = 0,1000122 auf 2 Stellen abgerundet 0,10 aufgerundet 0,11 aber durch das bekannte Problem ebenfalls 0,10. d.h. abrunden und aufrunden führt aufgrund des Problems zu demselben Ergebnis, addieren wir noch 0,01 sind wir bei 0,11

anderes Beispiel 3278/32786 = 0.0999816995 aufgerundet 0,10, abgerundet 0,09, hier ist auf und abgerundet unterschiedlich, also nichts addieren

Bsp 3: 3278/32780 = 0,1, diese Zahl ändert sich nicht durch auf oder abrunden also ebenfalls nichts addieren.

Wäre das eine Idee?
Gruß
Christian

Hi
ich hab mir mal deine Beispieldatei angeschaut.
die Datenmenge ist 32790 und nicht 32786
dh der Rangwert 3790 wird korrekterweise mit 10% ausgegeben, weil er 10% ist.
wenn man noch 4 Zeilen löscht um auf die Datenmenge 32786 zu kommen, dann wird der Rangwert 3279 auch wunschgemäß als 11% vom Makro ausgegeben.
so wie es aussieht, rechnen die Makros richtig, aber du hast die Datenmenge falsch im Kopf.
Gruß Daniel

Hallo Daniel,

danke erstmal.
da kommen wir der Sache vielleicht schon näher. Zuerst einmal, es sind nach meiner Zählung zumindest, 32790. Ich habe lediglich die 4 Texte mitgezählt, die in der Spalte stehen, du vermutlich nicht. Bei diesen Texten handelt es sich um Daten aus dem 19. Jhdt., die bekanntlich von Excel nicht als Zahl/Datum sondern als Text interpretiert werden. Genau zu diesem Zweck sollte eigentlich der Codeteil

  ' Wenn Text "dd.mm.yyyy"

    If InStr(v, ".") > 0 Then

        Teile = Split(v, ".")

        If UBound(Teile) = 2 Then

            Tag = val(Teile(0))

            Monat = val(Teile(1))

            jahr = val(Teile(2))

            DatumZuSortierwert = jahr * 10000# + Monat * 100# + Tag

            Exit Function

        End If

    End If

dienen, damit diese trotzdem ein Ranking bekommen.

Wenn du jetzt darauf gestoßen bist, dass diese doch nicht ins Ranking einbezogen werden und deshalb der Quotient für das Makro <0,11 ist, wäre ich froh wenn man das ändern könnte.

Gruß
Christian

Bei den 4 Texten handelt es sich um 15.05.1898, 03.11.1896, 30.09.1887 und 31.10.1876

keine Ahnung. Bei mir in Excel 365 werden diese Werte von VBA wie normale Datumswerte korrekt mit berechnet.
die 10% für die genannte Zeile sind aus meiner Sicht korrekt.

Hallo Daniel,

trotzdem sind es aber 32790 Zeilen und nicht 32786 und damit der Quotient >0,1.

Gruß
Christian

in der von dir benannten Zeile ist der Rang-Wert 3279
damit ist bei 32790 Zeilen der Quotient genau 0,1.
wenn du weniger Zeilen hast (32786) wird der Quotient größer

bei meinem Quotienten >0,1 haben die Daten vor 1900 gefehlt.

Aber wenn dem so ist, und wir nochmal auf das Ursprungsproblem zurückkommen war die 10% ja doch korrekt und das Makro hätte diese Zeile in das Blatt AZN übernehmen müssen.

Gruß
Christian

das hat dir Case doch schon in der allerersten Antwort erklärt.

wenn der Quotient genau 0,1 ist, dann ist er mit der Filterung <0,1 nicht dabei.
wenn er dabei sein soll, dann müsstest du <=0,1 verwenden und nicht <0,1, so wie in deinem Code

ich weiß auch nicht was hier grad los ist, ich sitze seit Tagen an dem Problem, versuche ja auch selber parallel zu euch weiterhin eine Lösung zu finden, anscheinend habe ich bei all dem dann jetzt selber den Überblick verloren. Sorry (auch an Case).

Die Prüfung zu ändern, bekomme ich hin.

Danke
Christian

Naja, um ehrlich zu sein, hatte zur Ermittlung Anzahl und nicht anzahl2 genutzt, weil ich in dem moment nicht an die 4 daten vor 1900 gedacht hatte

du hättest einfach nur mal kontrollieren müssen, was das Makro so rechnet und welche Anzahl es annimmt.

Gut wenn ich den Code richtig verstehe , dann machst du das Sub M_snb()

  ' sn = gesamter Datenblock aus Tabelle1, beginnend bei Zelle (1,4) = Spalte D

  sn = Tabelle1.Cells(1, 4).CurrentRegion

  

  ' sp = gesamter Datenblock aus Tabelle2, beginnend bei Zelle (1,2) = Spalte B

  sp = Tabelle2.Cells(1, 2).CurrentRegion

    

  ' Dictionary erzeugen

  With CreateObject("scripting.dictionary")

  

    'Dictionary aus Tabelle2 aufbauen

    ' Key = Wert aus Spalte B

    ' Value = Wert aus Spalte C

    For j = 1 To UBound(sp)

      .Item(sp(j, 1)) = sp(j, 2)

    Next



    'Tabelle1 Zeile für Zeile durchgehen

    For j = 1 To UBound(sn)

    

      ' Wenn der Wert in Spalte F (3. Spalte im Array) <= 0,1 ist

      If sn(j, 3) <= 0.1 Then

      

        ' Dann ersetze diesen Wert durch den Dictionary‑Wert

        ' Key ist der Wert aus Spalte D (1. Spalte im Array)

        sn(j, 3) = .Item(sn(j, 1))

        

        ' Und lösche diesen Key aus dem Dictionary

        .Remove sn(j, 1)

     End If

   Next

 End With

    

'Ergebnis in Tabelle3 schreiben


 Tabelle3.Cells(1).Resize(UBound(sn), 3) = sn

End Sub

kurz gesagt wenn Wert <=0,1 ersetze ihn durch einen Wert aus dem Dictionary.

Gruß
Christian