roccihrs
27.04.2010, 16:35
Hallo,
Ich habe hier einen Quellcode für meine
Modul1
-----------------------
Option Explicit
Sub Spielstart()
Dim Spieler1 As String
Dim Spieler2 As String
Sheets(1).Range("A3:G8").Clear
Sheets(2).Range("A3:G8").ClearContents
With Sheets(1).Range("A3:G8").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Spieler1 = InputBox("Bitte geben Sie den Namen des 1. Spielers ein", _
"Spieler 1", Cells(2, 9))
Spieler2 = InputBox("Bitte geben Sie den Namen des 2. Spielers ein", _
"Spieler 2", Cells(2, 10))
Cells(2, 9) = Spieler1
Cells(2, 10) = Spieler2
Cells(4, 12) = 3
End Sub
Sub ZugMachen()
Dim Spalte As Integer
Dim i As Integer
Dim Zelle As Range
Dim NeuesSpiel As Integer
'On Error Resume Next
Spalte = Selection.Column
'Spaltenprüfung: Ist die Spalte voll?
If Cells(3, Spalte).Interior.ColorIndex <> -4142 Then
MsgBox "Sorry, diese Spalte ist schon voll!" & _
vbLf & "Bitte wählen Sie eine andere", vbOKOnly
Exit Sub
End If
'Spielstein setzen
For i = 8 To 3 Step -1
If Cells(i, Spalte).Interior.ColorIndex = -4142 Then
Cells(i, Spalte).Interior.ColorIndex = Cells(4, 12)
Sheets(2).Cells(i, Spalte) = _
Sheets(1).Cells(i, Spalte).Interior.ColorIndex
Exit For
End If
Next
'Spiel prüfen
For Each Zelle In Sheets(2).Range("A3:K14")
If Zelle = 12 Then
MsgBox Cells(2, 9) & " hat gewonnen!"
NeuesSpiel = MsgBox("Neues Spiel?", vbYesNo, "Nochmal?")
If NeuesSpiel = vbYes Then
Call Spielstart
Else
Exit Sub
End If
ElseIf Zelle = 20 Then
MsgBox Cells(2, 10) & " hat gewonnen!"
NeuesSpiel = MsgBox("Neues Spiel?", vbYesNo, "Nochmal?")
If NeuesSpiel = vbYes Then
Call Spielstart
Else
Exit Sub
End If
End If
Next
'Spielerwechsel
If Cells(4, 12) = 3 Then
Cells(4, 12) = 5
Else
Cells(4, 12) = 3
End If
End Sub
----------------------
Modul2
---------------
Option Explicit
Sub Makro4()
ActiveSheet.ClearArrows
Selection.ShowPrecedents
End Sub
DIESE ARBEITSMAPPE
----------
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Aktiv As Integer
Aktiv = Selection.Column
Set Target = Intersect(Target, Sheets(1).Range("A2:G2"))
If Target Is Nothing Then
'MsgBox "Bitte lassen Sie den Cursor im gelben Bereich."
If Aktiv > 7 Then
Aktiv = 7
End If
Cells(2, Aktiv).Select
End If
End Sub
Download als fertige Excel-Datei: excel-center Foren :: Beispieldateien Microsoft Excel (http://www.excel-center.de/foren/file.php?4,file=9624)
Für jeden, der mir die einzelnen Befehle erklären kann oder sie umformulieren kann, gibts einen Usenext Account (keinen Trial Account)!
Ich muss die Commands erklären können und den Code umändern, damit er so aussieht, als hätte ich ihn geschrieben =)
MfG
roccihrs
Ich habe hier einen Quellcode für meine
Modul1
-----------------------
Option Explicit
Sub Spielstart()
Dim Spieler1 As String
Dim Spieler2 As String
Sheets(1).Range("A3:G8").Clear
Sheets(2).Range("A3:G8").ClearContents
With Sheets(1).Range("A3:G8").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Sheets(1).Range("A3:G8").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Spieler1 = InputBox("Bitte geben Sie den Namen des 1. Spielers ein", _
"Spieler 1", Cells(2, 9))
Spieler2 = InputBox("Bitte geben Sie den Namen des 2. Spielers ein", _
"Spieler 2", Cells(2, 10))
Cells(2, 9) = Spieler1
Cells(2, 10) = Spieler2
Cells(4, 12) = 3
End Sub
Sub ZugMachen()
Dim Spalte As Integer
Dim i As Integer
Dim Zelle As Range
Dim NeuesSpiel As Integer
'On Error Resume Next
Spalte = Selection.Column
'Spaltenprüfung: Ist die Spalte voll?
If Cells(3, Spalte).Interior.ColorIndex <> -4142 Then
MsgBox "Sorry, diese Spalte ist schon voll!" & _
vbLf & "Bitte wählen Sie eine andere", vbOKOnly
Exit Sub
End If
'Spielstein setzen
For i = 8 To 3 Step -1
If Cells(i, Spalte).Interior.ColorIndex = -4142 Then
Cells(i, Spalte).Interior.ColorIndex = Cells(4, 12)
Sheets(2).Cells(i, Spalte) = _
Sheets(1).Cells(i, Spalte).Interior.ColorIndex
Exit For
End If
Next
'Spiel prüfen
For Each Zelle In Sheets(2).Range("A3:K14")
If Zelle = 12 Then
MsgBox Cells(2, 9) & " hat gewonnen!"
NeuesSpiel = MsgBox("Neues Spiel?", vbYesNo, "Nochmal?")
If NeuesSpiel = vbYes Then
Call Spielstart
Else
Exit Sub
End If
ElseIf Zelle = 20 Then
MsgBox Cells(2, 10) & " hat gewonnen!"
NeuesSpiel = MsgBox("Neues Spiel?", vbYesNo, "Nochmal?")
If NeuesSpiel = vbYes Then
Call Spielstart
Else
Exit Sub
End If
End If
Next
'Spielerwechsel
If Cells(4, 12) = 3 Then
Cells(4, 12) = 5
Else
Cells(4, 12) = 3
End If
End Sub
----------------------
Modul2
---------------
Option Explicit
Sub Makro4()
ActiveSheet.ClearArrows
Selection.ShowPrecedents
End Sub
DIESE ARBEITSMAPPE
----------
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Aktiv As Integer
Aktiv = Selection.Column
Set Target = Intersect(Target, Sheets(1).Range("A2:G2"))
If Target Is Nothing Then
'MsgBox "Bitte lassen Sie den Cursor im gelben Bereich."
If Aktiv > 7 Then
Aktiv = 7
End If
Cells(2, Aktiv).Select
End If
End Sub
Download als fertige Excel-Datei: excel-center Foren :: Beispieldateien Microsoft Excel (http://www.excel-center.de/foren/file.php?4,file=9624)
Für jeden, der mir die einzelnen Befehle erklären kann oder sie umformulieren kann, gibts einen Usenext Account (keinen Trial Account)!
Ich muss die Commands erklären können und den Code umändern, damit er so aussieht, als hätte ich ihn geschrieben =)
MfG
roccihrs