AW: hier Beispiel Namen aus Liste erstellen
22.11.2009 22:20:49
Josef
Hallo Claudia,
hier meine Version.
' **********************************************************************
' Modul: Modul6 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Enum CN_NAME_STATUS
CN_DONT_EXIST = -1
CN_NAME_EXISTS = 1
CN_REF_EXISTS = 2
End Enum
Public Function IsValidName(ByVal strName As String) As Boolean
Dim objRegExp As Object, rng As Range
If IsNumeric(Left(strName, 1)) Then Exit Function
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\%\&\$\§\(\)\[\]\{\}\s\t\r\n\f]{1,255}$"
.IgnoreCase = True
IsValidName = .test(strName)
End With
Set objRegExp = Nothing
End Function
Private Function checkName(ByVal strName As String, ByVal strRef As String, Optional ByRef WBook As Workbook) As CN_NAME_STATUS
Dim nName As Name
checkName = CN_DONT_EXIST
strRef = LCase(Replace(Replace(strRef, "$", ""), "=", ""))
If WBook Is Nothing Then Set WBook = ThisWorkbook
For Each nName In WBook.Names
If nName.Name = strName Then
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
checkName = CN_NAME_EXISTS Or CN_REF_EXISTS
Else
checkName = CN_NAME_EXISTS
End If
Exit Function
End If
If LCase(Replace(Replace(nName.RefersTo, "$", ""), "=", "")) = strRef Then
If nName.Name = strName Then
checkName = CN_REF_EXISTS Or CN_NAME_EXISTS
Else
checkName = CN_REF_EXISTS
End If
Exit Function
End If
Next
End Function
Sub addNames()
Dim strName As String, strRef As String, strRange As String
Dim lngRow As Long, lngLast As Long, chkName As CN_NAME_STATUS
Dim objSh As Worksheet, rng As Range
With Sheets("Blattnamen")
On Error Resume Next
Set objSh = Sheets(.Index + 1)
On Error GoTo 0
If Not objSh Is Nothing Then
lngLast = Application.Max(20, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 20 To lngLast
If .Cells(lngRow, 1) <> "" And .Cells(lngRow, 2) <> "" Then
If IsValidName(.Cells(lngRow, 1)) Then
If IsNumeric(.Cells(lngRow, 3)) Then
If .Cells(lngRow, 3) > 0 Then
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Cells(lngRow, 3)
Else
strRange = .Cells(lngRow, 2) & "1:" & .Cells(lngRow, 2) & .Rows.Count
End If
Else
strRange = .Cells(lngRow, 2) & ":" & .Cells(lngRow, 2)
End If
On Error Resume Next
Set rng = objSh.Range(strRange)
On Error GoTo 0
If Not rng Is Nothing Then
strRef = "=" & objSh.Name & "!" & rng.Address
strName = .Cells(lngRow, 1)
chkName = checkName(strName, strRef)
If chkName = CN_DONT_EXIST Then
ThisWorkbook.Names.Add strName, strRef
.Cells(lngRow, 4) = "OK"
objSh.Range(strRange).Cells(1, 1) = strName
Else
.Cells(lngRow, 4) = "Überprüfen"
End If
Else
.Cells(lngRow, 4) = "Ungültiger Bezug"
End If
Set rng = Nothing
Else
.Cells(lngRow, 4) = "Ungültiger Name"
End If
End If
Next
Else
MsgBox "Kein Blatt nach der Tabelle 'Blattnamen' !", vbExclamation, "Fehler"
End If
End With
End Sub
Gruß Sepp