AW: Input Box
21.09.2003 11:33:15
WernerB.
Hallo Ernst,
es freut mich, wenn ich Dir mit dem Makro helfen konnte.
Zum - hoffentlich - besseren Verständnis habe ich das Makro noch mit einigen Kommentarzeilen versehen:
Option Explicit
Sub Ernst()
Dim c As Range
Dim SoNr As String, Bereich As String, lo As String, ru As String, Sz As String
Dim zo As Long
Dim sl As Integer, sr As Integer
Dim check As Boolean
'InputBox aufrufen
SoNr = InputBox("Sortier-Nummer eingeben:", "Abfrage")
'Prüfung, ob etwas eingegeben wurde (InputBox)
If SoNr = "" Then check = True
'Prüfung ob die Eingabe numerisch ist
If check = False Then
If Not IsNumeric(SoNr) Then check = True
End If
'Prüfung ob der Eingabewert zwischen 78 und 150 liegt
If check = False Then
If SoNr < 78 Or SoNr > 150 Then check = True
End If
'Hinweis und Makroabbruch, falls Prüfungen nicht bestanden
If check = True Then
MsgBox "Keine oder falsche Eingabe !" & vbCr & vbCr & _
"Makro-Abbruch !", vbOKOnly + vbInformation, _
"Dezenter Hinweis für " & Application.UserName & ":"
Exit Sub
End If
Application.ScreenUpdating = False
'Ermitteln der Überschriftenzeile des Bereichs "ALLE"
Bereich = Range("ALLE").Address(False, False)
lo = Left(Bereich, InStr(Bereich, ":") - 1) 'links oben
ru = Right(Bereich, Len(Bereich) - InStr(Bereich, ":")) 'rechts unten
zo = Range(lo).Row 'Zeile oben
sl = Range(lo).Column 'Spalte links
sr = Range(ru).Column 'Spalte rechts
'Zelladresse des Eingabewerts in Überschriftenzeile ermitteln
For Each c In Range(Cells(zo, sl), Cells(zo, sr))
If c.Value = SoNr Then
Sz = c.Address(False, False)
Exit For
End If
Next c
'Sortierung, wenn Eingabewert in Überschriftenzeile gefunden
If Sz <> "" Then
Range("ALLE").Sort Key1:=Range(Sz), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Hinweis, wenn Eingabewert in Überschriftenzeile nicht gefunden
Else
MsgBox "Überschrift nicht gefunden !" & vbCr & vbCr & _
"Keine Sortierung !", vbOKOnly + vbInformation, _
"Dezenter Hinweis für " & Application.UserName & ":"
End If
Application.ScreenUpdating = True
End Sub
Gruß WernerB.