ich möchte aus einem Formular Daten in ein Tabellenblatt (Zusammenfassung)übetragen.
Das ganze funktioniert mit einer Suchfunktion:
Das heißt
als Zellwerte die einen Datensatz von weiteren unterscheiden werden zwei Werte eingegeben (Kennung und Abschnitt).
Diese Werte werden auf dem Tabellenblatt (Zusammenfassung) gesucht und die anderen zugehörigen Daten dahinter auf die Spalten verteilt.
Ich hatte das ganze schon für eine Suchvariable, was auch super funktioniert hat, nur als die zweite mit rein sollte läuft es nicht.
Wer kann helfen:
Hier mein monströser code:
Sub Datensatz_übernehmen()
Worksheets("Datensätze").Unprotect "gms"
Dim suchVariable, a
Dim suchVariab, b
Dim Wert1, Wert2, Wert3, Wert4, Wert5, Wert6, Wert7, Wert8, Wert9, Wert10, Wert11, Wert12, Wert13, Wert14, Wert15, Wert16, Wert17, Wert18, Wert19, Wert20, Wert21, Wert22, Wert23, Wert24, Wert25
suchVariable = Sheets("Gewässermorphologische Grundlag").Cells(8, 4).Value And suchVariab = Sheets("Gewässermorphologische Grundlag").Cells(8, 15).Value
'Kennung und Gewässerabschnitt'
Wert1 = Sheets("Gewässermorphologische Grundlag").Cells(14, 4).Value 'Teileinzugsgebiet'
Wert2 = Sheets("Gewässermorphologische Grundlag").Cells(7, 31).Value 'Taltyp'
Wert3 = Sheets("Gewässermorphologische Grundlag").Cells(9, 35).Value 'Krümmungstyp'
Wert4 = Sheets("Gewässermorphologische Grundlag").Cells(14, 23).Value 'Lauftyp'
Wert5 = Sheets("Gewässermorphologische Grundlag").Cells(14, 31).Value 'Gewässergröße'
Wert6 = Sheets("Gewässermorphologische Grundlag").Cells(13, 34).Value 'Regimetyp'
Wert7 = Sheets("Gewässermorphologische Grundlag").Cells(19, 34).Value 'Gewässerlandschaft'
Wert8 = Sheets("Bewertung Gewässerbettdynamik").Cells(11, 7).Value 'Linienführung'
Wert9 = Sheets("Bewertung Gewässerbettdynamik").Cells(9, 14).Value 'Uferverbau'
Wert10 = Sheets("Bewertung Gewässerbettdynamik").Cells(29, 6).Value 'Querbauwerke'
Wert11 = Sheets("Bewertung Gewässerbettdynamik").Cells(28, 14).Value 'Abflußregelung'
Wert12 = Sheets("Bewertung Gewässerbettdynamik").Cells(36, 6).Value 'Uferbewuchs'
Wert13 = Sheets("Bewertung Gewässerbettdynamik").Cells(33, 14).Value 'Tiefenerosion'
Wert14 = Sheets("Bewertung Auedynamik").Cells(8, 6).Value 'Hochwasserschutzbauwerke'
Wert15 = Sheets("Bewertung Auedynamik").Cells(8, 16).Value 'Ausuferungsvermögen'
Wert16 = Sheets("Bewertung Auedynamik").Cells(17, 21).Value 'Auenutzung'
Wert17 = Sheets("Bewertung Auedynamik").Cells(16, 7).Value 'Uferstreifen'
Wert18 = Sheets("Bewertung Gewässerbettdynamik").Cells(11, 7).Value 'Linienführung'
Wert19 = Sheets("Bewertung Gewässerbettdynamik").Cells(30, 6).Value 'Strukturbildungsvermögen'
Wert20 = Sheets("Bewertung Gewässerbettdynamik").Cells(36, 6).Value 'Uferbewuchs'
Wert21 = Sheets("Bewertung Auedynamik").Cells(9, 16).Value 'Retention'
Wert22 = Sheets("Bewertung Auedynamik").Cells(18, 21).Value 'Entwicklungspotential'
Wert23 = Sheets("Gesamtbewertung").Cells(8, 5).Value 'Gewässerbettdynamik'
Wert24 = Sheets("Gesamtbewertung").Cells(8, 14).Value 'Auedynamik'
Wert25 = Sheets("Gesamtbewertung").Cells(12, 29).Value 'Strukturgüteklasse'
Sheets("Datensätze").Select
i = ActiveSheet.UsedRange.Rows.Count
a = 0
For x = 1 To i
If ActiveSheet.Cells(x, 1).Value = suchVariable And ActiveSheet.Cells(x, 2).Value = suchVariab Then 'Kennung und Abschnittsnummer'
ActiveSheet.Cells(x, 4).Value = Wert1 'Teileinzugsgebiet'
ActiveSheet.Cells(x, 7).Value = Wert2 'Taltyp'
ActiveSheet.Cells(x, 8).Value = Wert3 'Krümmungstyp'
ActiveSheet.Cells(x, 9).Value = Wert4 'Lauftyp'
ActiveSheet.Cells(x, 10).Value = Wert5 'Gewässergröße'
ActiveSheet.Cells(x, 11).Value = Wert6 'Regimetyp'
ActiveSheet.Cells(x, 12).Value = Wert7 'Gewässerlandschaft'
ActiveSheet.Cells(x, 13).Value = Wert8 'Linienführung'
ActiveSheet.Cells(x, 14).Value = Wert9 'Uferverbau'
ActiveSheet.Cells(x, 15).Value = Wert10 'Querbauwerke'
ActiveSheet.Cells(x, 16).Value = Wert11 'Abflußregelung'
ActiveSheet.Cells(x, 17).Value = Wert12 'Uferbewuchs'
ActiveSheet.Cells(x, 18).Value = Wert13 'Tiefenerosion'
ActiveSheet.Cells(x, 19).Value = Wert14 'Hochwasserschutzbauwerke'
ActiveSheet.Cells(x, 20).Value = Wert15 'Ausuferungsvermögen'
ActiveSheet.Cells(x, 21).Value = Wert16 'Auenutzung'
ActiveSheet.Cells(x, 22).Value = Wert17 'Uferstreifen'
ActiveSheet.Cells(x, 23).Value = Wert18 'Linienführung'
ActiveSheet.Cells(x, 24).Value = Wert19 'Strukturbildungsvermögen'
ActiveSheet.Cells(x, 25).Value = Wert20 'Uferbewuchs'
ActiveSheet.Cells(x, 26).Value = Wert21 'Retention'
ActiveSheet.Cells(x, 27).Value = Wert22 'Entwicklungspotential'
ActiveSheet.Cells(x, 28).Value = Wert23 'Gewässerbettdynamik'
ActiveSheet.Cells(x, 29).Value = Wert24 'Auedynamik'
ActiveSheet.Cells(x, 30).Value = Wert25 'Strukturgüteklasse'
a = a + 1
End If
Next x
If a = 0 Then
MsgBox ("Es wurde keine Eintrag mit dieser Kennnummer gefunden. Neuer Eintrag wurde eröffnet")
End If
If ActiveSheet.Cells(x, 1).Value = suchVariable And ActiveSheet.Cells(x, 2).Value = suchVariab Then 'Kennung und Abschnittsnummer'
ActiveSheet.Cells(x, 4).Value = Wert1 'Teileinzugsgebiet'
ActiveSheet.Cells(x, 7).Value = Wert2 'Taltyp'
ActiveSheet.Cells(x, 8).Value = Wert3 'Krümmungstyp'
ActiveSheet.Cells(x, 9).Value = Wert4 'Lauftyp'
ActiveSheet.Cells(x, 10).Value = Wert5 'Gewässergröße'
ActiveSheet.Cells(x, 11).Value = Wert6 'Regimetyp'
ActiveSheet.Cells(x, 12).Value = Wert7 'Gewässerlandschaft'
ActiveSheet.Cells(x, 13).Value = Wert8 'Linienführung'
ActiveSheet.Cells(x, 14).Value = Wert9 'Uferverbau'
ActiveSheet.Cells(x, 15).Value = Wert10 'Querbauwerke'
ActiveSheet.Cells(x, 16).Value = Wert11 'Abflußregelung'
ActiveSheet.Cells(x, 17).Value = Wert12 'Uferbewuchs'
ActiveSheet.Cells(x, 18).Value = Wert13 'Tiefenerosion'
ActiveSheet.Cells(x, 19).Value = Wert14 'Hochwasserschutzbauwerke'
ActiveSheet.Cells(x, 20).Value = Wert15 'Ausuferungsvermögen'
ActiveSheet.Cells(x, 21).Value = Wert16 'Auenutzung'
ActiveSheet.Cells(x, 22).Value = Wert17 'Uferstreifen'
ActiveSheet.Cells(x, 23).Value = Wert18 'Linienführung'
ActiveSheet.Cells(x, 24).Value = Wert19 'Strukturbildungsvermögen'
ActiveSheet.Cells(x, 25).Value = Wert20 'Uferbewuchs'
ActiveSheet.Cells(x, 26).Value = Wert21 'Retention'
ActiveSheet.Cells(x, 27).Value = Wert22 'Entwicklungspotential'
ActiveSheet.Cells(x, 28).Value = Wert23 'Gewässerbettdynamik'
ActiveSheet.Cells(x, 29).Value = Wert24 'Auedynamik'
ActiveSheet.Cells(x, 30).Value = Wert25 'Strukturgüteklasse'
End If
b = 0
For x = 1 To i
If ActiveSheet.Cells(x, 1).Value = suchVariable And ActiveSheet.Cells(x, 2).Value = suchVariab Then 'Kennung und Abschnittsnummer'
ActiveSheet.Cells(x, 4).Value = Wert1 'Teileinzugsgebiet'
ActiveSheet.Cells(x, 7).Value = Wert2 'Taltyp'
ActiveSheet.Cells(x, 8).Value = Wert3 'Krümmungstyp'
ActiveSheet.Cells(x, 9).Value = Wert4 'Lauftyp'
ActiveSheet.Cells(x, 10).Value = Wert5 'Gewässergröße'
ActiveSheet.Cells(x, 11).Value = Wert6 'Regimetyp'
ActiveSheet.Cells(x, 12).Value = Wert7 'Gewässerlandschaft'
ActiveSheet.Cells(x, 13).Value = Wert8 'Linienführung'
ActiveSheet.Cells(x, 14).Value = Wert9 'Uferverbau'
ActiveSheet.Cells(x, 15).Value = Wert10 'Querbauwerke'
ActiveSheet.Cells(x, 16).Value = Wert11 'Abflußregelung'
ActiveSheet.Cells(x, 17).Value = Wert12 'Uferbewuchs'
ActiveSheet.Cells(x, 18).Value = Wert13 'Tiefenerosion'
ActiveSheet.Cells(x, 19).Value = Wert14 'Hochwasserschutzbauwerke'
ActiveSheet.Cells(x, 20).Value = Wert15 'Ausuferungsvermögen'
ActiveSheet.Cells(x, 21).Value = Wert16 'Auenutzung'
ActiveSheet.Cells(x, 22).Value = Wert17 'Uferstreifen'
ActiveSheet.Cells(x, 23).Value = Wert18 'Linienführung'
ActiveSheet.Cells(x, 24).Value = Wert19 'Strukturbildungsvermögen'
ActiveSheet.Cells(x, 25).Value = Wert20 'Uferbewuchs'
ActiveSheet.Cells(x, 26).Value = Wert21 'Retention'
ActiveSheet.Cells(x, 27).Value = Wert22 'Entwicklungspotential'
ActiveSheet.Cells(x, 28).Value = Wert23 'Gewässerbettdynamik'
ActiveSheet.Cells(x, 29).Value = Wert24 'Auedynamik'
ActiveSheet.Cells(x, 30).Value = Wert25 'Strukturgüteklasse'
b = b + 1
End If
Next x
If b = 0 Then
MsgBox ("Es wurde keine Eintrag mit dieser Kennnummer gefunden. Neuer Eintrag wurde eröffnet")
End If
If ActiveSheet.Cells(x, 1).Value = suchVariable And ActiveSheet.Cells(x, 2).Value = suchVariab Then 'Kennung und Abschnittsnummer'
ActiveSheet.Cells(x, 4).Value = Wert1 'Teileinzugsgebiet'
ActiveSheet.Cells(x, 7).Value = Wert2 'Taltyp'
ActiveSheet.Cells(x, 8).Value = Wert3 'Krümmungstyp'
ActiveSheet.Cells(x, 9).Value = Wert4 'Lauftyp'
ActiveSheet.Cells(x, 10).Value = Wert5 'Gewässergröße'
ActiveSheet.Cells(x, 11).Value = Wert6 'Regimetyp'
ActiveSheet.Cells(x, 12).Value = Wert7 'Gewässerlandschaft'
ActiveSheet.Cells(x, 13).Value = Wert8 'Linienführung'
ActiveSheet.Cells(x, 14).Value = Wert9 'Uferverbau'
ActiveSheet.Cells(x, 15).Value = Wert10 'Querbauwerke'
ActiveSheet.Cells(x, 16).Value = Wert11 'Abflußregelung'
ActiveSheet.Cells(x, 17).Value = Wert12 'Uferbewuchs'
ActiveSheet.Cells(x, 18).Value = Wert13 'Tiefenerosion'
ActiveSheet.Cells(x, 19).Value = Wert14 'Hochwasserschutzbauwerke'
ActiveSheet.Cells(x, 20).Value = Wert15 'Ausuferungsvermögen'
ActiveSheet.Cells(x, 21).Value = Wert16 'Auenutzung'
ActiveSheet.Cells(x, 22).Value = Wert17 'Uferstreifen'
ActiveSheet.Cells(x, 23).Value = Wert18 'Linienführung'
ActiveSheet.Cells(x, 24).Value = Wert19 'Strukturbildungsvermögen'
ActiveSheet.Cells(x, 25).Value = Wert20 'Uferbewuchs'
ActiveSheet.Cells(x, 26).Value = Wert21 'Retention'
ActiveSheet.Cells(x, 27).Value = Wert22 'Entwicklungspotential'
ActiveSheet.Cells(x, 28).Value = Wert23 'Gewässerbettdynamik'
ActiveSheet.Cells(x, 29).Value = Wert24 'Auedynamik'
ActiveSheet.Cells(x, 30).Value = Wert25 'Strukturgüteklasse'
End If
Worksheets("Datensätze").Protect "gms"
End Sub