Mehrere for each Schleifen mit mehreren Bedingunge
27.02.2015 10:34:44
Sandra
ich versuche mich immer durch googlen und probieren durch VBA zu wühlen. Leider gelingt es mir gerade gar nicht und hoffe auf Hilfe/Unterstützung. Kurz zu meinem Vorhaben. Ich habe mehrere Tabellenblätter und extrem viele Daten, die nur durch Zuordnungen mit IDs klappt, da einige Daten zu mehreren Personen zugeordnet werden können. D.h. es ist keine 1 zu 1 Zuordnung.
Das ist so ein Versuch von mir es zu lösen. Entschuldigt bitte. Ich weiß, dass es schlecht ist, aber ich wollte nicht mit "leeren Händen" nach Hilfe suchen..
Sub WerteZuordnung()
Dim wksZuordnungsSheet As Worksheet
Dim wksPersonen As Worksheet
Dim wksEigenschaften As Worksheet
Dim ZelleEigenschaftenZuordnen As Range
Dim ZelleZuordnung As Range
Dim ZelleEigenschaften As Range
Dim Variable As Variant
Dim Variable2 As Variant
Dim Variable3 As Variant
' Fehlermeldungen, Events und Bildschirmaktualisierung deaktivieren
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' D4 bis D100 nach Eintragungen absuchen
For Each ZelleEigenschaftenZuordnen In Sheets("2. Eigenschaften zuordnen").Range("D4:D100")
' Wenn Zelle nicht leer, dann den Wert in "Variable" speichern
If ZelleEigenschaftenZuordnen "" Then
ZelleEigenschaftenZuordnen.Value = Variable
End If
' B4 bis B8584 absuchen, ob der bereits gefundene Wert mit einem in dieser Spalte "matcht"
For Each ZelleZuordnung In Sheets("IV.Zuordnung").Range("B4:B8584")
ElseIf ZelleZuordnung.Value = ZelleEigenschaftenZuordnen.Value Then
' In Variable2 den Wert eine Zelle daneben speichern
Variable2 = ZelleZuordnung.Offset(0, 1).Value
End If
' E4 bis E567 absuchen, ob der Wert vorher mit einem in dieser Spalte "matcht"
For Each ZelleEigenschaften In Sheets("II.Eigenschaften").Range("E4:E567")
ElseIf ZelleEigenschaften.Value = ZelleEigenschaftenZuordnen.Value Then
' Wert dieser Zelle kopieren
ZelleEigenschaftenZuordnen.Value.Copy
End If
wksZuordnungsSheet.Activate
' Falls die Zelle daneben leer ist, hier einfügen
ElseIf ZelleEigenschaftenZuordnen.Offset(0, 1) "" Then
wksMappingThreats.ZelleEigenschaftenZuordnen.Offset(0, 1).Paste
' Wenn die Zelle schon besetzt ist, Zeile darunter einfügen und Wert einfügen
Else
ZelleEigenschaftenZuordnen.Rows.Insert
wksZuordnungsSheet.ZelleEigenschaftenZuordnen.Offset(0, 1).Paste
End If
Next ZelleEigenschaftenZuordnen
Next ZelleZuordnung
Next ZelleEigenschaften
' Fehlermeldungen, Events und Bildschirmaktualisierung deaktivieren
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub