AW: benannter Bereich: Zelladresse links oben und ..
07.06.2008 20:37:30
Ramses
Hallo
hier noch eine Alternative
Option Explicit
Sub Test()
Dim testStr As String
Dim suchBereich As String
Dim retRange As Integer
suchBereich = "Testbereich"
'******************************
On Error Resume Next
suchBereich = InputBox("Welche Namensbereich möchten Sie prüfen " & Chr$(10) & "z.B. Testbereich", "Namensbereich definieren", "Testbereich")
If StrPtr(suchBereich) = 0 Or suchBereich = "" Then Exit Sub
retRange = Int(InputBox("Welche Zelle möchten sie erhalten ? " & Chr$(10) & "0 = Startzelle, 1 = Endzelle", "Rückgabewert definieren", 0))
If Not IsNumeric(retRange) Then Exit Sub
On Error GoTo 0
testStr = FindAddressXP(Range(suchBereich).Address(0, 0), retRange)
MsgBox "Ergebnis aus Array" & Chr$(10) & _
"Beginn: " & testStr & Chr$(10) & _
"Spalte: " & Range(testStr).Column & Chr$(13) & _
"Zeile: " & Range(testStr).Row, vbInformation + vbOKOnly, "Adresse"
testStr = FindAddressAll(Range(suchBereich).Address(0, 0), retRange)
MsgBox "Ergebnis ohne Array" & Chr$(10) & _
"Beginn: " & testStr & Chr$(10) & _
"Spalte: " & Range(testStr).Column & Chr$(13) & _
"Zeile: " & Range(testStr).Row, vbInformation + vbOKOnly, "Adresse"
End Sub
Function FindAddressXP(strAdd As String, retVal As Integer) As String
'by Ramses
'Geht erst ab Office XP
'retVal = 0 = Startadresse(z.B. A1), 1 = EndAddresse( z.B. C10)
Dim strX As Variant
If strAdd = "" Then
FindAddressXP = ""
Exit Function
End If
strX = Split(strAdd, ":")
FindAddressXP = strX(retVal)
End Function
Function FindAddressAll(strAdd As String, retVal As Integer) As String
'by Ramses
'Geht für alle Office Versionen
'retVal = 0 = Startadresse, 1 = EndAddresse
Dim strX As Variant
If strAdd = "" Then
FindAddressAll = ""
Exit Function
End If
If retVal = 0 Then
FindAddressAll = Left(strAdd, InStr(1, strAdd, ":") - 1)
ElseIf retVal = 1 Then
FindAddressAll = Right(strAdd, Len(strAdd) - InStr(1, strAdd, ":"))
End If
End Function
Gruss Rainer