Guten Abend zusammen,
habe folgende Codes vorliegen:
Modul1 :
Sub Berechne(strWas As String, strWo As String)
Dim strZ As String, ZeiS As Long, ZeiP As Long, Zei As Long
Dim rngWo As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabbi")
Set rngWo = .Range(strWo)
rngWo.Offset(0, 1).Resize(154, 3).ClearContents
If strWas = "Nix machen" Then GoTo Ende
For Zei = 0 To 150 Step 5
If rngWo.Offset(Zei, 0) = "" Then GoTo Ende
For ZeiS = 0 To 3 Step 1
If Alle(strWas, rngWo.Offset(Zei + ZeiS, 0)) = True Then
rngWo.Offset(Zei + ZeiS, 1).Value = Range("I2")
End If
Next ZeiS
Next Zei
End With
Ende:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function Alle(Was As String, ByRef Zelle As Range) As Boolean
Dim intI As Integer, Wert As Integer, intVergleich As Integer
Select Case Was
Case "Quersumme"
intVergleich = Tabelle1.Cells(8, Zelle.Column).Value
For intI = 1 To Len(Zelle.Value)
Wert = Wert + CInt(Mid(Zelle.Value, intI, 1))
Next
Alle = IIf(Wert = intVergleich, True, False)
Case "Durch"
intVergleich = Tabelle1.Cells(8, Zelle.Column + 4).Value
On Error Resume Next
Alle = IIf(Zelle.Value Mod intVergleich = 0, True, False)
On Error GoTo 0
Case "Primzahl"
For intI = 2 To Int(Sqr(Zelle.Value))
If Zelle.Value Mod intI = 0 Then Exit For
Next intI
Alle = intI \> Int(Sqr(Zelle.Value))
Case Else
'nix
End Select
End Function
Tabelle1:
Option Explicit
Private Sub Runde1\_Change()
Call Berechne(Runde1.Value, "F13")
End Sub
Private Sub Runde2\_Change()
Call Berechne(Runde2.Value, "M13")
End Sub
Private Sub Runde3\_Change()
Call Berechne(Runde3.Value, "T13")
End Sub
Private Sub Runde4\_Change()
Call Berechne(Runde4.Value, "AA13")
End Sub
Private Sub Runde5\_Change()
Call Berechne(Runde5.Value, "AH13")
End Sub
Private Sub Runde6\_Change()
Call Berechne(Runde6.Value, "AO13")
End Sub
Private Sub Runde7\_Change()
Call Berechne(Runde7.Value, "AV13")
End Sub
Private Sub Runde8\_Change()
Call Berechne(Runde8.Value, "BC13")
End Sub
Private Sub Runde9\_Change()
Call Berechne(Runde9.Value, "BJ13")
End Sub
Private Sub Runde10\_Change()
Call Berechne(Runde10.Value, "BQ13")
End Sub
Private Sub Worksheet\_SelectionChange(ByVal Target As Range)
Dim Ber, Ziel, Index As Integer, I, Wert
If Target.Count 1 Then Exit Sub
If Target.Row 166 Then Exit Sub
Ber = Array("F", "M", "T", "AA", "AH", "AO", "AV", "BC", "BJ", "BQ", "BX", "CE", "CL", "CS", "CZ")
Ziel = Array("F2", "P2", "W2", "AD2", "AK2", "AR2", "AY2", "BF2", "BM2", "BT2", "CA2", "CH2", "CO2", "CV2", "DC2")
Index = -1
For I = LBound(Ber) To UBound(Ber)
If Target.Column = Range(Ber(I) & 1).Column Then
Index = I
Exit For
End If
Next I
If Index = -1 Then Exit Sub
Wert = Application.Sum(Target.Offset(-(Target.Row + 2) Mod 5, 0).Resize(4, 1))
Range(Ziel(Index)).Value = Wert
End Sub
Private Sub Worksheet\_Change(ByVal Target As Range)
If Target.Count \> 1 Then Exit Sub
If Target.Row \> 161 Or Target.Row 5 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Application.CountIf(Range("E13:E166"), Target.Value) \> 1 Then
Application.EnableEvents = False
MsgBox Target.Value & " ist doppelt vorhanden"
Target.ClearContents
Target.Select
Application.EnableEvents = True
End If
End Sub
'Private Sub Worksheet\_Change(ByVal Target As Range)
'Set Target = Intersect(Target, Range("F13:F200"))
'If Target Is Nothing Then Exit Sub
'Application.EnableEvents = False
'Call Berechne(Tabelle2.OLEObjects("Runde" & 1).Object.Value, "F13")
'Application.EnableEvents = True
'End Sub
Was ich nun gerne hätte ist folgendes: In einer ComboBox wird eine Funktion(Quersumme,Durch,Primzahl oder nix machen ausgewählt. Dann entsprechend der Auswahl die gewünschte Quersumme in F8 oder den Teiler in J8 eingegeben. In Zelle I2 noch den Bonus,das wars. Nun soll der Code nach jeder Eingabe in den Zellen F13-F166 prüfen und ggf. den Wert aus I2 in die Felder G13-G166 setzen.
Reinhard war so nett und hat mir eben diesen Code gebastelt der auch eigentlich funktioniert,nur das bei Auswahl sofort der Wert aus I2 in die Zellen G13-G166 setzt.
Nun hat er mir die Korrektur gepostet,die ich aber nicht einbauen kann,da ich schon eine „Private Sub Worksheet_Change(ByVal Target As Range)“ habe.
Nun meine Frage: Wie verschmelze ich die beiden,damit dieser Code auch ordentlich funzt?
Habe die Tabellle hier mal hochgeladen.
http://www.uploadagent.de/show-176315-1313519048.html
LG Frank
