ich habe eine Anwendung geschrieben, mit der man Daten aus einem Eingabeblatt in der Datenbank sichert. Nun will ich diese auch von der Datenbank ins Eingabeblatt lesen. Die Datei ist ca. 1.6 MB gross. Mein PC AMD-K6, 64 MB RAM.
Nun folgendes Probelm:
Der untenstehende Code klappt tip top jedoch nur ca. 15 x hintereinander, je nach je (Tagesform von PC??). Bin der Meinung wenn es 1x geht sollte es doch auch 1000x möglich sein oder?.
Private Sub Image9_Click()
frmHolzschlag.Show ' UserForm wird geladen
End Sub
Private Sub UserForm_Initialize() ' gewünschte Zeile kann
Dim frm As UserForm ' angeklickt werden
Dim i As Integer, Zeile As Integer
On Error Resume Next
Application.ScreenUpdating = False
Zeile = 2
Do While Sheets("NuPro").Cells(Zeile, 1) <> ""
Zeile = Zeile + 1
Loop
i = Zeile
Set frm = frmHolzschlag
With frm.ListBox1
.ColumnCount = 2
.ColumnHeads = True
.RowSource = "NuPro!A2:B" & i
.ControlSource = "Eingabe!E60"
.BoundColumn = 1
.ColumnWidths = "1cm;5cm"
End With
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click() ' Ok Button
Sheets("Eingabe").Select ' UserForm wird aus dem
Unload frmHolzschlag ' Speicher geladen
Unload Me
Call Holzschlag_Suchen ' Modul wird aufgerufen
End Sub
'Holzschlag suchen
Sub Holzschlag_Suchen()
Dim gZelle As Range
Dim Bereich As Range
Dim Bereich1 As Range
Dim sBegriff$
Dim Daten(125) As Variant
Dim Zelle As Range
Dim i As Integer
Dim Zeile As Integer
Dim Stelle As Integer
Erase Daten
Application.ScreenUpdating = False
Call HolzschlagLöschen ' Prozedur Holzschlaglöschen
' Daten einlesen
On Error Resume Next
ActiveWorkbook.Unprotect "*********"
Worksheets("Datenbank").Visible = True
Worksheets("DB-Ndh").Visible = True
Worksheets("DB-Lbh").Visible = True
Sheets("Eingabe").Select
Erase Daten
Daten(1) = Range("E60")
Sheets("Datenbank").Select
Zeile = 1
Do While Cells(Zeile, 1) <> ""
Zeile = Zeile + 1
Loop
sBegriff = Daten(1)
Range("A1:A" & Zeile - 1).Find(Daten(1), , LookIn:=xlValues, LookAt:=xlWhole).Activate
Erase Daten
Stelle = 1
For i = 0 To 123
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
'Daten im Array auf Blatt Eingabe übertragen
Sheets("Eingabe").Select
Range("E60") = Daten(1)
Range("E61") = Daten(2)
Range("E62") = Daten(3)
Range("E63") = Daten(4)
Range("E64") = Daten(5)
Range("E65") = Daten(6)
Range("E66") = Daten(7)
Range("E67") = Daten(8)
Range("E68") = Daten(9)
Range("E69") = Daten(10)
Sheets("Sortiment").Select
Range("B1") = Daten(11)
Range("B2") = Daten(12)
Sheets("Eingabe").Select
Range("E70") = Daten(13)
Range("E71") = Daten(14)
Range("E72") = Daten(15)
Range("E73") = Daten(16)
Range("E74") = Daten(17)
Range("F74") = Daten(18)
Range("E75") = Daten(19)
Range("E76") = Daten(20)
Range("E77") = Daten(21)
Range("E78") = Daten(22)
Range("E79") = Daten(23)
Range("I70") = Daten(31)
Range("I71") = Daten(32)
Range("I72") = Daten(33)
Range("I75") = Daten(34)
Range("I76") = Daten(35)
Range("I77") = Daten(36)
Range("I78") = Daten(37)
Range("I79") = Daten(38)
Range("J75") = Daten(39)
Range("J76") = Daten(40)
Range("J77") = Daten(41)
Range("J78") = Daten(42)
Range("J79") = Daten(43)
Range("I80") = Daten(44)
Range("I81") = Daten(45)
Range("I82") = Daten(46)
Range("I83") = Daten(47)
Sheets("Nachkalk").Select
Stelle = 48
For Zeile = 13 To 21
For i = 6 To 7
Cells(Zeile, i) = Daten(Stelle)
Stelle = Stelle + 1
Next i
Range("A" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Range("B28") = Daten(75)
Range("B29") = Daten(76)
Range("B30") = Daten(77)
Range("B31") = Daten(78)
Range("A32") = Daten(79)
Range("B32") = Daten(80)
Range("B34") = Daten(81)
Range("B35") = Daten(82)
Range("B36") = Daten(83)
Range("B37") = Daten(84)
Range("A38") = Daten(85)
Range("B38") = Daten(86)
Range("F28") = Daten(87)
Range("F29") = Daten(88)
Range("F30") = Daten(89)
Range("F31") = Daten(90)
Range("E32") = Daten(91)
Range("F32") = Daten(92)
Range("F34") = Daten(93)
Range("F35") = Daten(94)
Range("E36") = Daten(95)
Range("F36") = Daten(96)
Range("E37") = Daten(97)
Range("F37") = Daten(98)
Range("E38") = Daten(99)
Range("F38") = Daten(100)
Range("B47") = Daten(101)
Range("B48") = Daten(102)
Range("A49") = Daten(103)
Range("B49") = Daten(104)
Range("B51") = Daten(105)
Range("B52") = Daten(106)
Range("B53") = Daten(107)
Range("A54") = Daten(108)
Range("B54") = Daten(109)
Range("F47") = Daten(110)
Range("F48") = Daten(111)
Range("E49") = Daten(112)
Range("F49") = Daten(113)
Range("E50") = Daten(114)
Range("F50") = Daten(115)
Range("E51") = Daten(116)
Range("F51") = Daten(117)
Range("E52") = Daten(118)
Range("F52") = Daten(119)
Range("E53") = Daten(120)
Range("F53") = Daten(121)
Range("E54") = Daten(122)
Range("F54") = Daten(123)
'Nadelholz 1 BA-Daten von Blatt Ndh-DB einlesen
Sheets("Eingabe").Select
Erase Daten
Daten(1) = Range("E60")
Sheets("DB-Ndh").Select
Zeile = 1
Do While Cells(Zeile, 1) <> ""
Zeile = Zeile + 1
Loop
sBegriff = Daten(1)
Range("A1:A" & Zeile - 1).Find(Daten(1), , LookIn:=xlValues, LookAt:=xlWhole).Activate
Set gZelle = ActiveCell
Set Bereich = Range(ActiveCell(), ActiveCell.Offset(0, 144))
Bereich.Select
For Each Zelle In Bereich
If Zelle.Value = 0 Then
Zelle.Value = ""
End If
Next Zelle
gZelle.Select
Erase Daten
Sheets("DB-Ndh").Select
Stelle = 1
If ActiveCell.Offset(0, 24).Value = "" Then GoTo BA2
Daten(Stelle) = "Fichte"
Stelle = Stelle + 1
For i = 1 To 20
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
BA2:
If ActiveCell.Offset(0, 48).Value = "" Then GoTo BA3
Daten(Stelle) = "Tanne"
Stelle = Stelle + 1
For i = 25 To 44
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
BA3:
If ActiveCell.Offset(0, 72).Value = "" Then GoTo BA4
Daten(Stelle) = "Lärche"
Stelle = Stelle + 1
For i = 49 To 68
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
BA4:
If ActiveCell.Offset(0, 96).Value = "" Then GoTo BA5
Daten(Stelle) = "Föhre"
Stelle = Stelle + 1
For i = 73 To 92
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
BA5:
If ActiveCell.Offset(0, 120).Value = "" Then GoTo BA6
Daten(Stelle) = "Douglasie"
Stelle = Stelle + 1
For i = 97 To 116
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
BA6:
If ActiveCell.Offset(0, 144).Value = "" Then GoTo Format
Daten(Stelle) = "übrig. Ndh"
Stelle = Stelle + 1
For i = 121 To 140
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
Format:
'Workbook HSK-ProFrostDB "Ndh" werden leere Zellen mit O aufgefüllt
Set Bereich = Range(ActiveCell(), ActiveCell.Offset(0, 144))
Bereich.Select
For Each Zelle In Bereich
If Zelle.Value = "" Then
Zelle.Value = 0
End If
Next Zelle
gZelle.Select
'Daten im Array werden im Blatt eingefügt
Sheets("Sortiment").Select
If Daten(1) = "" Then GoTo Übertrag2
Range("B4") = Daten(1)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("C" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Übertrag2:
Sheets("Sortiment").Select
If Daten(22) = "" Then GoTo Übertrag3
Range("B5") = Daten(22)
Stelle = 23
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("E" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Übertrag3:
Sheets("Sortiment").Select
If Daten(43) = "" Then GoTo Übertrag4
Range("B6") = Daten(43)
Stelle = 44
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("G" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Übertrag4:
Sheets("Sortiment").Select
If Daten(64) = "" Then GoTo Übertrag5
Range("B7") = Daten(64)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("I" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Übertrag5:
Sheets("Sortiment").Select
If Daten(85) = "" Then GoTo LH1
Range("B8") = Daten(85)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("K" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
LH1:
'Laubholz 1 BA-Daten von Blatt Ndh-DB einlesen
Sheets("Eingabe").Select
Erase Daten
Daten(1) = Range("E60")
Sheets("DB-Lbh").Select
Zeile = 1
Do While Cells(Zeile, 1) <> ""
Zeile = Zeile + 1
Loop
sBegriff = Daten(1)
Range("A1:A" & Zeile - 1).Find(Daten(1), , LookIn:=xlValues, LookAt:=xlWhole).Activate
Set gZelle = ActiveCell
Set Bereich1 = Range(ActiveCell(), ActiveCell.Offset(0, 120))
Bereich1.Select
For Each Zelle In Bereich1
If Zelle.Value = 0 Then
Zelle.Value = ""
End If
Next Zelle
gZelle.Select
Erase Daten
Sheets("DB-Lbh").Select
Stelle = 1
If ActiveCell.Offset(0, 24).Value = "" Then GoTo LH2
Daten(Stelle) = "Buche"
Stelle = Stelle + 1
For i = 1 To 20
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
LH2:
If ActiveCell.Offset(0, 48).Value = "" Then GoTo LH3
Daten(Stelle) = "Eiche"
Stelle = Stelle + 1
For i = 25 To 44
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
LH3:
If ActiveCell.Offset(0, 72).Value = "" Then GoTo LH4
Daten(Stelle) = "Esche"
Stelle = Stelle + 1
For i = 49 To 68
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
LH4:
If ActiveCell.Offset(0, 96).Value = "" Then GoTo LH5
Daten(Stelle) = "Ahorn"
Stelle = Stelle + 1
For i = 73 To 92
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
LH5:
If ActiveCell.Offset(0, 120).Value = "" Then GoTo FormatLH
Daten(Stelle) = "übrig. Lbh"
Stelle = Stelle + 1
For i = 97 To 116
Daten(Stelle) = ActiveCell.Offset(0, i)
Stelle = Stelle + 1
Next i
FormatLH:
'Workbook HSK-ProFrostDB "Ndh" werden leere Zellen mit O aufgefüllt
Set Bereich = Range(ActiveCell(), ActiveCell.Offset(0, 120))
Bereich.Select
For Each Zelle In Bereich
If Zelle.Value = "" Then
Zelle.Value = 0
End If
Next Zelle
gZelle.Select
'Daten im Array werden im Blatt eingefügt
Sheets("Sortiment").Select
If Daten(1) = "" Then GoTo ÜbertragLH2
Range("B9") = Daten(1)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("M" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
ÜbertragLH2:
Sheets("Sortiment").Select
If Daten(22) = "" Then GoTo ÜbertragLH3
Range("B10") = Daten(22)
Stelle = 23
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("O" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
ÜbertragLH3:
Sheets("Sortiment").Select
If Daten(43) = "" Then GoTo ÜbertragLH4
Range("B11") = Daten(43)
Stelle = 44
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("Q" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
ÜbertragLH4:
Sheets("Sortiment").Select
If Daten(64) = "" Then GoTo ÜbertragLH5
Range("B12") = Daten(64)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("S" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
ÜbertragLH5:
Sheets("Sortiment").Select
If Daten(85) = "" Then GoTo Ende
Range("B13") = Daten(85)
Stelle = 2
Sheets("Anzeichnung").Select
For Zeile = 14 To 33
Range("U" & Zeile) = Daten(Stelle)
Stelle = Stelle + 1
Next Zeile
Ende:
Erase Daten
End If
Worksheets("Datenbank").Visible = False
Worksheets("DB-Ndh").Visible = False
Worksheets("DB-Lbh").Visible = False
ActiveWorkbook.Protect "**********3"
Sheets("Eingabe").Select
Range("E59").Value = "Gedruckt"
Range("E8").Select
Application.ScreenUpdating = True
End Sub
Sub HolzschlagLöschen()
Application.ScreenUpdating = False
Sheets("Eingabe").Select
If Range("E60") = "" Then Exit Sub
' Anzeichnungsprotokoll löschen
Sheets("Anzeichnung").Select
Range( _
"C14:C33,E14:E33,G14:G33,I14:I33,K14:K33,M14:M33,O14:O33,Q14:Q33,S14:S33,U14:U33" _
).Select
Selection.ClearContents
Range("C14").Select
Sheets("Sortiment").Select ' Achtung, jetzt wird noch das
Range("B4:B13").Select ' Klassenmodul aufgerufen
Selection.ClearContents ' siehe unten
Range("B4").Select
Sheets("Eingabe").Select
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD14").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
If Range("AD15").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
If Range("AD16").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
If Range("AD17").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
If Range("AD18").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
If Range("AD19").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox1.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox2_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD14").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
If Range("AD15").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
If Range("AD16").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
If Range("AD17").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
If Range("AD18").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
If Range("AD19").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox2.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox3_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD14").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
If Range("AD15").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
If Range("AD16").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
If Range("AD17").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
If Range("AD18").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
If Range("AD19").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox3.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox4_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD14").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
If Range("AD15").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
If Range("AD16").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
If Range("AD17").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
If Range("AD18").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
If Range("AD19").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox4.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox5_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD14").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
If Range("AD15").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
If Range("AD16").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
If Range("AD17").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
If Range("AD18").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
If Range("AD19").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox5.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox6_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD20").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox6.ListIndex = -1
End If
If Range("AD21").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox6.ListIndex = -1
End If
If Range("AD22").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox6.ListIndex = -1
End If
If Range("AD23").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox6.ListIndex = -1
End If
If Range("AD24").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox6.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox7_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD20").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox7.ListIndex = -1
End If
If Range("AD21").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox7.ListIndex = -1
End If
If Range("AD22").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox7.ListIndex = -1
End If
If Range("AD23").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox7.ListIndex = -1
End If
If Range("AD24").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox7.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox8_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD20").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox8.ListIndex = -1
End If
If Range("AD21").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox8.ListIndex = -1
End If
If Range("AD22").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox8.ListIndex = -1
End If
If Range("AD23").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox8.ListIndex = -1
End If
If Range("AD24").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox8.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox9_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD20").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox9.ListIndex = -1
End If
If Range("AD21").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox9.ListIndex = -1
End If
If Range("AD22").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox9.ListIndex = -1
End If
If Range("AD23").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox9.ListIndex = -1
End If
If Range("AD24").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox9.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Private Sub ComboBox10_Change()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Anzeichnung").Select
If Range("AD20").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox10.ListIndex = -1
End If
If Range("AD21").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox10.ListIndex = -1
End If
If Range("AD22").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox10.ListIndex = -1
End If
If Range("AD23").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox10.ListIndex = -1
End If
If Range("AD24").Value > 1 Then
MsgBox "Sie können pro Anzeichnungsprotokoll nur einmal " & Chr(13) & _
"die gleiche Baumart eingeben!", vbInformation, "WARNUNG"
Sheets("Anzeichnung").ComboBox10.ListIndex = -1
End If
Application.ScreenUpdating = True
End Sub
Ich habe den Durckblick nicht mehr und weiss nicht warum diese Abstürze. Z.T. kommt eine Fehlermeldung "Excel verursachte einen Fehler durch eine ungültige Seite in Modul VBE6.dll bei 015f:65009f43." Dann wieder Modul MSO9.dll oder Excel.exe oder eben keine Meldung.
Wer hat den Durckblick und kann mir helfen.....??
Danke
Gruss Thomas