Hier die Lösung, die eine Option dafür darstellt.
Sub Ausfuellen()
' ====================================================================================
' Makro: Ausfuellen
'
' ====================================================================================
' History:
'
' Inhalt:
' Es soll die Zeile bestimmt werden, die den Suchtext = "#Ende# nichts hinter dieser Zeile eintragen" enthält,
' der Zeilenwert soll gespeichert bleiben für ein spätere Schleife
' Es soll zur Spalte X (Prüfungsnummer) gegangen werden. (Achtung es könnte sein, das diese Info nächste Woche
' an eine andere Stelle wandert.)
' Dann soll ab Zeile 3 von X geprüft werden, ob der Wert numerisch ist und bis zum Ende nur einmal vorkommt.
' Im Prinzip soll ein Makro erzeugt werden, was auf Klick in Spalte X alle Zellen durchnummeriert , wo bei das
' Makro auch später eingefügte Spalten mit Zahlenwerten versehen soll
' Bei vorliegendem Beispiel soll das Makro erkennen, das in Zeile 13 der höchste Wert 6 steht und dies der Basiswert ist, um in Zeile 7 den Wert 7, in zeile 8 den ' Wert 8 und in Zeile 9 den Wert 9 , in Zeile 11 dann den Wert 10, in Zeile 12 den Wert 11 und in Zeile 14 dann den Wert 12 bis zum Ende eintragen.
' Es soll eine Fehlermeldung geben, wenn ein Wert mehrfach vorkommt.
' ====================================================================================
'
Dim wbZiel As Workbook
Set wbZiel = ThisWorkbook
Dim RngBereich As Range
Dim rZeile As Range
Dim rSpalte As Range
Dim endList As Integer
Dim anfangZeile As Integer
Dim findSpalte As Integer
Dim Fehler As Integer
Dim Gefunden As Boolean
Dim Suchtext As String: Suchtext = "#Ende# nichts hinter dieser Zeile eintragen"
Dim maxWert As Integer
'Es soll die Zeile bestimmt werden, die den Suchtext =
' "#Ende# nichts hinter dieser Zeile eintragen" enthält,
' der Zeilenwert soll gespeichert bleiben für ein spätere Schleife
wbZiel.Sheets("MTU-Tool").Select
Columns("A:A").Select
With Selection.Rows
Set rZeile = .Find(what:=Suchtext, lookat:=xlWhole)
If Not rZeile Is Nothing Then
endList = rZeile.Row
Else
Fehler = 1 'Doppelter Wert gefunden
endList = 0 'Fehler, da nicht gefunden -> raus aus Makro
GoTo Ende
End If
End With
' Es soll zur Spalte X (Prüfungsnummer) gegangen werden.
' (Achtung es könnte sein, das diese Info nächste Woche an
' eine andere Stelle wandert.)
Suchtext = "Prüfungs #"
Rows("2:2").Select
With Selection.Columns
Set rSpalte = .Find(what:=Suchtext, lookat:=xlWhole)
If Not rSpalte Is Nothing Then
findSpalte = rSpalte.Column
Else
Fehler = 2 'Fehler da nichts gefunden, -> raus
findSpalte = 0
GoTo Ende
End If
End With
' Dann soll ab Zeile 3 von X geprüft werden, ob der Wert numerisch ist
' und bis zum Ende nur einmal vorkommt.
anfangZeile = 3
Gefunden = False
Dim x As Long
For x = anfangZeile To endList
Cells(x, findSpalte).Interior.ColorIndex = 2 'Farbe zurücksetzen, falls sie schon einmal markiert wurde
If WorksheetFunction.CountIf(Range(Cells(anfangZeile, findSpalte), Cells(endList, findSpalte)), Cells(x, findSpalte)) > 1 Then
Cells(x, findSpalte).Interior.ColorIndex = 3
Gefunden = True
End If
Next x
Dim response As Byte
If Gefunden Then
response = MsgBox("Es wurden doppelte Einträge gefunden und rot markiert! """ & _
vbLf & """ Abruch?", 4, "Achtung:")
If response = vbYes Then Exit Sub
End If
' Im Prinzip soll ein Makro erzeugt werden, was auf Klick in Spalte X alle Zellen durchnummeriert , wo bei das Makro auch
' später eingefügte Spalten mit Zahlenwerten versehen soll
Set RngBereich = ActiveSheet.Range(Cells(anfangZeile, findSpalte), Cells(endList, findSpalte))
maxWert = maxWert + 1
Dim Zelle As Variant
For Each Zelle In Selection
If Zelle = "" And Cells(Zelle.Row, 1) <> "" Then
Cells(Zelle.Row, Zelle.Column) = maxWert
maxWert = Application.Max(RngBereich)
Range(Cells(anfangZeile, findSpalte), Cells(endList - 1, findSpalte)).Select
maxWert = maxWert + 1
End If
Next Zelle
MsgBox "Ready!"
Exit Sub
' Es soll eine Fehlermeldung geben, wenn ein Wert mehrfach vorkommt.
Ende:
Select Case Fehler
Case 1
MsgBox "Der Begriff """ & Suchtext & """ wurde nicht gefunden.", _
48, " Hinweis für " & Application.UserName
Case 2
MsgBox "Der Begriff """ & Suchtext & """ wurde nicht gefunden.", _
48, " Hinweis für " & Application.UserName
Case 3
MsgBox "Doppelter Wert """ & x & """ gefunden .", _
48, " Hinweis für " & Application.UserName
End Select
Exit Sub
End Sub
|