AW: Formblatt automatisch ausfüllen
28.09.2020 10:35:08
UweD
Hallo
viel Arbeit
- Rechtsclick auf den Tabellenblattreiter von Herstellbarkeitsanalyse
- Code anzeigen
- Code dort reinkopieren
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim TB As Worksheet, Zeile As Long
Set TB = Sheets("technische Daten")
With ActiveSheet
If Target.Count = 1 And Target = .Range("C4") Then
If WorksheetFunction.CountIf(TB.Columns(1), Target) > 0 Then
Zeile = WorksheetFunction.Match(Target, TB.Columns(1), 0)
Application.EnableEvents = False
'Kopfangaben***
.Range("C5") = TB.Cells(Zeile, 2) 'lesen aus Spalte B
.Range("C6") = TB.Cells(Zeile, 3)
.Range("C7") = TB.Cells(Zeile, 4)
.Range("C8") = TB.Cells(Zeile, 5)
'.... usw.
'zu 2)***
.Range("L15") = TB.Cells(Zeile, 13)
'erst alle aus
.Shapes("Kontrollkästchen 2").ControlFormat.Value = xlOff
.Shapes("Kontrollkästchen 3").ControlFormat.Value = xlOff
.Shapes("Kontrollkästchen 4").ControlFormat.Value = xlOff
Select Case TB.Cells(Zeile, 14)
Case "ja"
.Shapes("Kontrollkästchen 2").ControlFormat.Value = xlOn
Case "nein"
.Shapes("Kontrollkästchen 3").ControlFormat.Value = xlOn
Case "bedingt"
.Shapes("Kontrollkästchen 4").ControlFormat.Value = xlOn
End Select
'zu 3)***
.Range("L18") = TB.Cells(Zeile, 15)
'usw.
Else
MsgBox "Keiner Werte gefunden"
End If
End If
End With
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Tipp:
Anstelle von 3 Kontrollkästchen solltest du Optionbuttons nehmen, es ist doch immer nur eine Möglichkeit gegeben.. das vereinfacht dern Code
LG UweD