Daten mit unterschiedlichen Bezeichnungen aus unterschiedlichen Worksheets miteinander vergleichen

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von Mono.

    Daten mit unterschiedlichen Bezeichnungen aus unterschiedlichen Worksheets miteinander vergleichen

    Hallo liebe Community,

    ich bin blutiger VB-Anfänger und habe mir zu dieser Frage bereits einen Wolf gegoogelt, komme aber leider nicht weiter. Bitte habt Nachsicht, falls diese Frage schon anderswo beantwortet wurde (ich glaube aber nicht in dieser Form).

    Es geht um eine Excel-Tabelle mit mehreren Worksheets, welche automatisch von einem Computersystem generiert wird. Auf dem Worksheet "Treatments" finden sich in Spalte C verschiedene Einheiten (mg, µg, mmol, IE, MBq und noch ein paar mehr). Ein weiteres Worksheet "ExternalIDs" enthält in Spalte L die gleichen Einheiten, welche aber maschinenlesbar gemacht wurden (z.B. wird "µg" zu "mcg", aus "IE" wird "units". Jetzt möchte ich die beiden Spalten (Also Worksheet "Treatments", C2:C5000 und Worksheet "ExternalIDs", L2:L5000) miteinander vergleichen, und wenn die jeweilige Zuordnung passt die Zelle grün hinterlegen. Falls es nicht passt, möchte ich die Zelle rot hinterlegen.
    Aus juristischen Gründen ist es nicht möglich, die Daten einfach rüber zu kopieren - sie müssen händisch eingetragen werden, das Script soll lediglich eine zusätzliche "Kontrollinstanz" bilden.

    Probleme habe ich vor allem damit, dass die Felder mit ungleichen Werten benannt sind und auf unterschiedlichen Worksheets liegen. Folgenden Code habe ich mir bereits zusammengeschustert:

    Quellcode

    1. Sub UnitComparison_Makro()
    3. Dim ZelleA As Range
    4. Dim ZelleB As Range
    5. Dim a As Range
    6. Dim b As Range
    8. Set a = ThisWorkbook.Worksheets("Treatments").Range("C2:C5000")
    9. Set b = ThisWorkbook.Worksheets("ExternalIDs").Range("L2:L5000")
    11. For Each ZelleA In a
    12. Set ZelleB = b.Cells(ZelleA.Row, 12)
    13. If ZelleA.Value = "µg" And ZelleB.Value = "mcg" Then
    14. a.Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    16. End If
    17. Next ZelleA
    19. End Sub


    Leider markiert er nicht was er soll... habe ich ein Brett vor dem Kopf? :S Ich hoffe das ich diese "For"-Schleife (wenn sie einmal klappt) einfach kopieren und für die anderen Werte anpassen kann...

    Vielen Dank fürs Lesen und liebe Grüße!
    Jan

    Liebe Leute,

    mir ist es gerade wie Schuppen vor den Augen gefallen - eine (wenn auch ziemlich unpraktikable) Lösung für das Problem.

    Quellcode

    1. Sub UnitComparison_Makro()
    3. Dim ZelleA As Range
    4. Dim ZelleB As Range
    5. Dim a As Range
    6. 'Dim b As Range
    8. Set a = ThisWorkbook.Worksheets("Treatments").Range("C2:C5000")
    9. 'Set b = ThisWorkbook.Worksheets("ExternalIDs").Range("L2:L5000")
    11. For Each ZelleA In a
    12. Set ZelleB = Worksheets("ExternalIDs").Cells(ZelleA.Row, 12)
    13. If ZelleA.Value = "µg" And ZelleB = "mcg" Then
    14. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    15. ElseIf ZelleA.Value = "ml" And ZelleB = "ml" Then
    16. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    17. ElseIf ZelleA.Value = "mg" And ZelleB = "mg" Then
    18. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    19. ElseIf ZelleA.Value = "Mega IE" And ZelleB = "MEGAunits" Then
    20. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    21. ElseIf ZelleA.Value = "ng" And ZelleB = "ng" Then
    22. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    23. ElseIf ZelleA.Value = "IE" And ZelleB = "units" Then
    24. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    25. ElseIf ZelleA.Value = "kIE" And ZelleB = "kunits" Then
    26. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    27. ElseIf ZelleA.Value = "mmol" And ZelleB = "mmol" Then
    28. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    29. ElseIf ZelleA.Value = "g" And ZelleB = "g" Then
    30. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 4
    31. Else
    32. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = 3
    33. End If
    34. Next ZelleA
    37. End Sub


    Viel besser wäre es natürlich, wenn man die Einheitenpaare in einem dictionary o.ä. speichern und vergleichen könnte... Vor allem würde mir das helfen, damit ich nicht bei neuen Datenpaaren gleich die ganze Schleife bearbeiten sondern nur das "dictionary" ergänzen muss. Fällt jemandem von euch dazu eine Lösung ein?

    Liebe Grüße und vielen Dank,
    Jan

    Hi,

    ungefähr so würde es gehen:

    Visual Basic-Quellcode

    1. Private unitsDictionary As Object
    2. Sub UnitComparison_Makro()
    3. Dim ZelleA As Range
    4. Dim ZelleB As Range
    5. Dim a As Range
    6. 'Dictionary befüllen
    7. Call FillDictionary
    8. 'Dim b As Range
    9. Set a = ThisWorkbook.Worksheets("Treatments").Range("C2:C5000")
    10. 'Set b = ThisWorkbook.Worksheets("ExternalIDs").Range("L2:L5000")
    11. For Each ZelleA In a
    12. Set ZelleB = Worksheets("ExternalIDs").Cells(ZelleA.Row, 12)
    13. Worksheets("Treatments").Cells(ZelleA.Row, 3).Interior.ColorIndex = GetColorForFields(ZelleA.Value, ZelleB.Value)
    14. Next ZelleA
    17. End Sub
    19. 'irgendwelche Daten mal füllen
    20. Sub FillDictionary()
    21. Set unitsDictionary = CreateObject("Scripting.Dictionary")
    22. unitsDictionary.Add "ml", "ml"
    23. unitsDictionary.Add "kIE", "kunits"
    24. unitsDictionary.Add "µg", "mcg"
    25. unitsDictionary.Add "mq", "mqe"
    26. End Sub
    27. 'prüfen ob es passt und entsprechenden Farbcode zurückgeben
    28. Function GetColorForFields(valueOriginal As String, valueMachine As String)
    29. 'nicht im Dictionary => rot
    30. If Not unitsDictionary.Exists(valueOriginal) Then
    31. GetColorForFields = 3
    32. Exit Function
    33. End If
    34. 'Wert ist identisch => grün
    35. If unitsDictionary(valueOriginal) = valueMachine Then
    36. GetColorForFields = 4
    37. Exit Function
    38. End If
    39. 'nix gefunden => rot
    40. GetColorForFields = 3
    41. End Function
    Das ist meine Signatur und sie wird wunderbar sein!

Facebook
Telefonspende