Private
Sub
btnGrundUebernahme_Click()
Dim
Zelle
As
Range
Dim
Bereich
As
Range
Dim
intLeerPos
As
Integer
Dim
Grund2
As
String
Dim
Grund1
As
String
Dim
lngLast
As
Long
lngLast = Cells(Rows.Count, 1).
End
(xlUp).Row + 1
Set
Bereich = ThisWorkbook.Worksheets(
"QM-Bericht"
).Range(
"A25, A29, A33"
)
Grund1 = frmQMB.cmbGrund1QMB.Value
Grund2 = frmQMB.cmbGrund2QMB.Value
intLeerPos = InStr(Grund2,
" "
)
For
Each
Zelle
In
Bereich
If
Left(Zelle.Value, 1) = Left(Grund1, 1)
Then
Zelle.Offset(lngLast, 2).Value = Mid(Grund2, InStr(Grund2,
" "
) + 1)
Zelle.Offset(lngLast, 1).Value = Left(Grund2, 3)
End
If
Next
Zelle
If
Range(
"A25"
).Value =
"x"
Then
Range(
"A25"
).Value = Left(Grund1, 1)
Range(
"A25"
).Offset(0, 1).Value = Mid(Grund1, InStr(Grund1,
" "
) + 1)
Range(
"A25"
).Offset(1, 0).Value = Left(Grund2, 3)
Range(
"A25"
).Offset(1, 1).Value = Mid(Grund2, InStr(Grund2,
" "
) + 1)
ElseIf
Range(
"A25"
).Value <>
"x"
And
Range(
"A29"
).Value =
"x"
Then
Range(
"A29"
).Value = Left(Grund1, 1)
Range(
"A29"
).Offset(0, 1).Value = Mid(Grund1, InStr(Grund1,
" "
) + 1)
Range(
"A29"
).Offset(1, 0).Value = Left(Grund2, 3)
Range(
"A29"
).Offset(1, 1).Value = Mid(Grund2, InStr(Grund2,
" "
) + 1)
ElseIf
Range(
"A25"
).Value <>
"x"
And
Range(
"A29"
).Value <>
"x"
And
Range(
"A33"
).Value =
"x"
Then
Range(
"A33"
).Value = Left(Grund1, 1)
Range(
"A33"
).Offset(0, 1).Value = Mid(Grund1, InStr(Grund1,
" "
) + 1)
Range(
"A33"
).Offset(1, 0).Value = Left(Grund2, 3)
Range(
"A33"
).Offset(1, 1).Value = Mid(Grund2, InStr(Grund2,
" "
) + 1)
Else
MsgBox
"Sie haben die Anzahl möglicher Hauptgründe erreicht!"
End
If
End
Sub