Version mit A's, E's und EA's und Löschen
13.11.2009 21:58:26
Erich
Hi Bernie aus Ffm vom RSC, (habe ich aus den Dateieigenschaften...)
hier eine erweiterte Fassung des Programms, das jetzt auch mit mehreren As und Es und EAs zurechtkommt,
und dazu auch eine Routine zum Löschen aller Zahlen auf einem Tabellenblatt.
Option Explicit
Sub StrickzahlenAE2()
Dim zz As Long, ss As Long, nn As Long, rngF As Range
Dim intVR As Integer, lngA As Long, lngE As Long, varB, lngB As Long
Dim lngS As Long, arrT, blnZahl As Boolean
Const lng1 As Long = 5
Const lngZ As Long = 29
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
For zz = lng1 To lngZ
nn = 0
arrT = .Transpose(.Transpose( _
Range(Cells(zz, 1), Cells(zz, LetzteSpalteInBereich(Rows(zz))))))
If (lngZ - zz) Mod 2 = 1 Then
intVR = 1: lngA = 1: lngE = UBound(arrT)
Else
intVR = -1: lngA = UBound(arrT): lngE = 1
End If
For ss = lngA To lngE Step intVR
Select Case arrT(ss)
Case "X", "EA"
nn = 0
Case "A"
nn = 0: blnZahl = intVR = 1
Case "E"
nn = 0: blnZahl = intVR = -1
Case Else
If blnZahl Then
nn = nn + 1: Cells(zz, ss) = nn
If rngF Is Nothing Then
Set rngF = Cells(zz, ss)
Else
Set rngF = Union(rngF, Cells(zz, ss))
End If
End If
End Select
Next ss
Next zz
rngF.Font.Size = 9
rngF.Font.Bold = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Sub LoescheZahlen()
Dim arrB, zz As Long, ss As Long
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet.UsedRange
arrB = .Value
For zz = 1 To UBound(arrB)
For ss = 1 To UBound(arrB, 2)
If Not IsEmpty(arrB(zz, ss)) And IsNumeric(arrB(zz, ss)) Then _
.Cells(zz, ss).ClearContents ' oder: Clear
Next ss
Next zz
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Function LetzteSpalteInBereich(rngB As Range) As Long
Dim rng As Range
Set rng = rngB.Find("*", rngB.Cells(1, 1), xlValues, , xlByColumns, xlPrevious)
If rng Is Nothing Then
LetzteSpalteInBereich = rngB.Cells(1, 1).Column
Else
LetzteSpalteInBereich = rng.Column
End If
End Function
Und hier die Mappe zum Spielen: https://www.herber.de/bbs/user/65886.xls
Die As und Es und EAs ibei den Tauben sollte ich nicht eintragen, oder?
Das Löschen der Zahlen funzt auch da.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort