Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.05.2024 11:17:06
Hyperlink zu Bild in Zelle
17.05.2024 11:15:40
Spalte und Makros gleichzeitig verschieben
17.05.2024 11:03:10
Ganze Zahl in Ganz-Zahl Kombinationen aufteilen (ohne Rest)
17.05.2024 10:40:53
Tabellen (formatiert) über VBA auswählen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1956to1960
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
1956to1960
1956to1960
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zweites Kriterium hinzufügen

Zweites Kriterium hinzufügen
11.12.2023 09:28:54
Fred Neumann
Ich habe ein prima Makro, welches relevant die Daten in der 1. Spalte vergleicht und bei "Treffer" entsprechende Daten von "Results" nach "Ziel" kopiert.
Meine Frage:
Wie ergänze ich das Makro, so das nicht nur in der 1. Spalte nach gleichen Wert abgeglichen wird, sondern jeweils in Spalte 1 +2 

Sub Results_Ziel()

    Application.ScreenUpdating = False

    

    Dim sn As Variant

    Dim sp As Variant

    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")



    ' Daten aus Tabelle "Ziel" einlesen

    sn = Sheets("Ziel").ListObjects(1).DataBodyRange



    ' Daten aus Tabelle "Results" einlesen und ins Dictionary übertragen

    sp = Sheets("Results").ListObjects(1).DataBodyRange

    For j = 1 To UBound(sp)

        On Error Resume Next

        dict.Add sp(j, 1), Array(sp(j, 9), sp(j, 10), sp(j, 11), sp(j, 12))

        On Error GoTo 0

    Next



    For j = 1 To UBound(sn)

        If dict.Exists(sn(j, 1)) Then

            sn(j, 69) = dict(sn(j, 1))(0)

            sn(j, 70) = dict(sn(j, 1))(1)

            sn(j, 71) = dict(sn(j, 1))(2)

            sn(j, 72) = dict(sn(j, 1))(3)

        End If

    Next

    Sheets("Ziel").ListObjects(1).DataBodyRange = sn

    Application.ScreenUpdating = True



End Sub

Kann ein Experte mir dies bitte korrigieren!?

Gruss
Fred

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zweites Kriterium hinzufügen
11.12.2023 10:33:05
Yal
Hallo Fred,

das Vorhaben ist nicht kompliziert, aber der Code, der Dir zur Verfügung gestellt wurde, macht die Verarbeitung nicht leicht zu Überschauen.

Im Code werden die Eingangswerte in je einem Array (die ich in arrQ umbenannt habe),
aus der "Quelle" wird ein Dictionary gebaut, dessen Besonderheit ist, dass jede Schlüssel nur einmal vorkommen darf und anhand der Schlüssel auch geprüft, ob eine Eintrag im Dictionary vorhanden ist (dieses Verfahren ist besonders bei vielen Einträge schneller als alle einzel zu prüfen).

Daher besteht die Aufgabe daran, der Schlüssel aus dem kombinierten Inhalt der Spalte 1 und 2 zu bauen und bei der Prüfung auch Spalte 1 und 2 zu vergleichen.
Um es leichter zu verstehen, habe ich den Aufbau der Schlüssel vorangestellt. 

Sub Results_Ziel()

Dim j As Long

Dim arrQ As Variant ' Q wie Quelle

Dim arrZ As Variant ' Z wie Ziel

Dim Schlüssel As String

Dim dict As Object

    

    Set dict = CreateObject("Scripting.Dictionary")



' Daten aus Tabelle "Results" einlesen und ins Dictionary übertragen, damit Doubletten beseitigt werden

    arrQ = Sheets("Results").ListObjects(1).DataBodyRange

    On Error Resume Next

    For j = 1 To UBound(arrQ)

        Schlüssel = arrQ(j, 1) & ";" & arrQ(j, 2)

        dict.Add Schlüssel, Array(arrQ(j, 9), arrQ(j, 10), arrQ(j, 11), arrQ(j, 12))

    Next

    On Error GoTo 0



' Daten aus Tabelle "Ziel" einlesen

    arrZ = Sheets("Ziel").ListObjects(1).DataBodyRange

' Vergleichen. Bei Treffer in spalten 69-72 ablegen

    For j = 1 To UBound(arrZ)

        Schlüssel = arrZ(j, 1) & ";" & arrZ(j, 2)

        If dict.Exists(Schlüssel) Then

            arrZ(j, 69) = dict(arrZ(j, 1))(0)

            arrZ(j, 70) = dict(arrZ(j, 1))(1)

            arrZ(j, 71) = dict(arrZ(j, 1))(2)

            arrZ(j, 72) = dict(arrZ(j, 1))(3)

        End If

    Next

    

' Ergebnisse zurückspielen

    Application.ScreenUpdating = False

    Sheets("Ziel").ListObjects(1).DataBodyRange = arrZ

    Application.ScreenUpdating = True

End Sub


Da deine beiden Datenbestand in Tabellen ("ListObject") vorliegen, wäre eine Verarbeitung mit Power Query auch machbar. Dann müsstest Du dich nicht mit VBA quälen.

VG
Yal
Anzeige
AW: Zweites Kriterium hinzufügen
11.12.2023 11:18:41
Fred Neumann
Hallo Yal,
vielen Dank für deine umfangreiche Erklärung. Das "verstehe" ich zwar, aber der Code .....
Wohl noch mehrere Nummern zu hoch für mich ...
Deine "Korrektur" gibt die Fehlermeldung: Typen unverträglich, Gelb markiert = "arrZ(j, 33) = dict(arrZ(j, 1))(0)"
Anscheinend müssen die Werte im Dictionary in den richtigen Datentyp konvertiert werden. Die Werte in Spalten 69 bis 72 in "Ziel" sind als Zahlen formatiert. - - Die Werte im Dictionary also in den Datentyp "Double" konvertiert werden müssen. - Vieleicht sehe ich das auch falsch (wie so vieles ...)
https://www.herber.de/bbs/user/164992.xlsb

Gruss
Fred
Anzeige
AW: Zweites Kriterium hinzufügen
11.12.2023 11:34:20
Yal
Hallo Fred,

das Problem findet eher bei dem Aufbau der Dictionary statt. Ich habe einfach übernommen, war da war.
Richtiger wäre, sicherzustellen, dass die Werte (.. .Value) in den Array übernommen werden: 

    On Error Resume Next

    For j = 1 To UBound(arrQ)

        Schlüssel = arrQ(j, 1) & ";" & arrQ(j, 2)

        dict.Add Schlüssel, Array(arrQ(j, 9).Value, arrQ(j, 10).Value, arrQ(j, 11).Value, arrQ(j, 12).Value)

    Next

    On Error GoTo 0


VG
Yal
vba - überprüfung einbauen
13.12.2023 18:19:02
Fred
.. ich habe mich mal für ein "Eigenkonstrukt" entschieden und es läuft tatsächlich :-)))) - ich habe die Funktion CDbl verwendet, um die Werte im Dictionary in den Datentyp "Double" zu konvertieren...
Das "neue Problem" nun (was sicherlich keines ist): Wenn "Treffer" gefunden werden und in Sheet "Ergebnisse" die Zellen leer sind, wird im "Ziel-Sheet (Comp)" die 0 (Null) eingetragen. Das irritiert und muss so angepaßt werden, das es keinen Eintrag "" gibt. 

Sub ergebnisse_comp()

    Dim j As Long

    Dim arrQ As Variant ' Q wie Quelle

    Dim arrZ As Variant ' Z wie Ziel

    Dim Schlüssel As String

    Dim dict As Object

    

    Set dict = CreateObject("Scripting.Dictionary")



    ' Daten aus Tabelle "Ergebnisse" einlesen und ins Dictionary übertragen, damit Doubletten beseitigt werden

    arrQ = Sheets("Ergebnisse").ListObjects(1).DataBodyRange

    On Error Resume Next

    For j = 1 To UBound(arrQ)

        Schlüssel = arrQ(j, 1) & ";" & arrQ(j, 2)

        dict.Add Schlüssel, Array(CDbl(arrQ(j, 5)), CDbl(arrQ(j, 6)), CDbl(arrQ(j, 7)), CDbl(arrQ(j, 8)), (arrQ(j, 9)), (arrQ(j, 10)))

    Next

    On Error GoTo 0



    ' Daten aus Tabelle "Comp" einlesen

    arrZ = Sheets("Comp").ListObjects(1).DataBodyRange

    ' Vergleichen. Bei Treffer in Spalten 33-36 ablegen

    For j = 1 To UBound(arrZ)

        Schlüssel = arrZ(j, 1) & ";" & arrZ(j, 2)

        If dict.Exists(Schlüssel) Then

            arrZ(j, 33) = dict(Schlüssel)(0)

            arrZ(j, 34) = dict(Schlüssel)(1)

            arrZ(j, 35) = dict(Schlüssel)(2)

            arrZ(j, 36) = dict(Schlüssel)(3)

            arrZ(j, 37) = dict(Schlüssel)(4)

            arrZ(j, 38) = dict(Schlüssel)(5)

        End If

    Next

    

    ' Ergebnisse zurückspielen

    Application.ScreenUpdating = False

    Sheets("Comp").ListObjects(1).DataBodyRange = arrZ

    Application.ScreenUpdating = True

End Sub

Kann ein Experte bitte mir dieses Makro entsprechend ergänzen?! Eventuell eine Anpassung die vor dem Übertragen überprüft, ob die Werte im Array im "Quell-Sheet" nicht leer sind, und überträgt sie nur dann in das "Ziel-Sheet", wenn alle Werte vorhanden sind.

Gruss
Fred


Anzeige
AW: vba - überprüfung einbauen
13.12.2023 20:04:59
Yal
Hmm...

vielleicht so: 
    For j = 1 To UBound(arrZ)

        Schlüssel = arrZ(j, 1) & ";" & arrZ(j, 2)

        If dict.Exists(Schlüssel) Then

            arrZ(j, 33) = dict(Schlüssel)(0)

            arrZ(j, 34) = dict(Schlüssel)(1)

            arrZ(j, 35) = dict(Schlüssel)(2)

            arrZ(j, 36) = dict(Schlüssel)(3)

            arrZ(j, 37) = dict(Schlüssel)(4)

            arrZ(j, 38) = dict(Schlüssel)(5)

        Else

            arrZ(j, 33) = ""

            arrZ(j, 34) = ""

            arrZ(j, 35) = ""

            arrZ(j, 36) = ""

            arrZ(j, 37) = ""

            arrZ(j, 38) = ""

        End If

    Next


VG
Yal
Anzeige

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige