Zum Inhalt springen

Excel Makro Script Parameter Typ ändern

Aus LHlab Wiki

Mit folgendem Script können im Excel verwendete Parameter, welche über den Namensmanager zu finden sind, im Typ geändert werden (Blatt vs Arbeitsmappe). Excel erlaubt dies nur initial, danach ist der Button deaktiviert.

  • Die neuen Parameternamen setzen wie folgt zusammen: <blatt>_<parametername>
  • Es werden diverse nicht erlaubte Zeichen entfernt.
  • Es werden die Blätter "_VORLAGE_Betrieb" und "_VORLAGE_Setup" ignoriert.
  • Es wird ein neues Blatt namens "Debug" erstellt, in welchem alle Aktionen dokumentiert werden.
Sub ReplaceLocalNamesWithWorkbookNames_WithDebug()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Long
    Dim localNm As Name
    Dim origName As String
    Dim sheetName As String
    Dim cleanSheet As String
    Dim cleanOrig As String
    Dim candidate As String
    Dim nmCheck As Name
    Dim exists As Boolean
    Dim suffix As Long
    Dim refers As String
    Dim vis As Boolean
    Dim addErr As Long
    Dim addErrDesc As String
    Dim dbgSheet As Worksheet
    Dim nextRow As Long
    Dim j As Long, tmp As String, ch As String
    Dim tmpCandidate As String
    
    Set wb = ThisWorkbook ' oder ActiveWorkbook falls gewünscht
    
    ' Debug-Blatt vorbereiten (anlegen oder leeren)
    On Error Resume Next
    Set dbgSheet = wb.Worksheets("debug")
    If dbgSheet Is Nothing Then
        Set dbgSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        dbgSheet.Name = "debug"
    Else
        dbgSheet.Cells.Clear
    End If
    On Error GoTo 0
    
    ' Kopf
    With dbgSheet
        .Range("A1").Value = "Status"
        .Range("B1").Value = "Alte Name (lokal)"
        .Range("C1").Value = "Neuer Name (global)"
        .Range("D1").Value = "Bereich (Blatt)"
        .Range("E1").Value = "Bezieht sich auf"
    End With
    nextRow = 2
    
    ' Performance/Events ausschalten
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo FinallyClean ' Sicherstellen, dass am Ende aufgeräumt wird
    
    ' Hauptschleife über Blätter
    For Each ws In wb.Worksheets
        ' Überspringe Vorlagen-Blätter komplett
        If ws.Name = "_VORLAGE_Betrieb" Or ws.Name = "_VORLAGE_Setup" Then
            dbgSheet.Cells(nextRow, 1).Value = "Übersprungen"
            dbgSheet.Cells(nextRow, 4).Value = ws.Name
            nextRow = nextRow + 1
            GoTo NextSheet
        End If
        
        ' Durchlaufe lokale Namen des Blatts rückwärts (sicher beim Löschen)
        If ws.Names.Count > 0 Then
            For i = ws.Names.Count To 1 Step -1
                Set localNm = ws.Names(i)
                
                ' Ursprünglichen lokalen Namen ermitteln (falls "Sheet!Name" vorkommt)
                origName = localNm.Name
                If InStr(origName, "!") > 0 Then
                    origName = Mid(origName, InStrRev(origName, "!") + 1)
                End If
                
                ' Blattname normalisieren (Hochkomma entfernen)
                sheetName = ws.Name
                If Len(sheetName) >= 2 Then
                    If Left(sheetName, 1) = "'" And Right(sheetName, 1) = "'" Then
                        sheetName = Mid(sheetName, 2, Len(sheetName) - 2)
                    End If
                End If
                
                ' Referenz und Sichtbarkeit merken
                refers = localNm.RefersTo
                vis = localNm.Visible
                
                ' Bereinigung: ungültige/unerwünschte Zeichen ersetzen
                cleanSheet = sheetName
                cleanSheet = Replace(cleanSheet, " ", "_")
                cleanSheet = Replace(cleanSheet, "'", "")
                cleanSheet = Replace(cleanSheet, "[", "_")
                cleanSheet = Replace(cleanSheet, "]", "_")
                cleanSheet = Replace(cleanSheet, "/", "_")
                cleanSheet = Replace(cleanSheet, "\", "_")
                cleanSheet = Replace(cleanSheet, ":", "_")
                cleanSheet = Replace(cleanSheet, "?", "_")
                cleanSheet = Replace(cleanSheet, "*", "_")
                cleanSheet = Replace(cleanSheet, vbTab, "_")
                cleanSheet = Replace(cleanSheet, "(", "_")
                cleanSheet = Replace(cleanSheet, ")", "_")
                cleanSheet = Replace(cleanSheet, ",", "_")
                cleanSheet = Replace(cleanSheet, ";", "_")
                cleanSheet = Replace(cleanSheet, ".", "_")
                
                cleanOrig = origName
                cleanOrig = Replace(cleanOrig, " ", "_")
                cleanOrig = Replace(cleanOrig, "'", "")
                cleanOrig = Replace(cleanOrig, "(", "_")
                cleanOrig = Replace(cleanOrig, ")", "_")
                cleanOrig = Replace(cleanOrig, "[", "_")
                cleanOrig = Replace(cleanOrig, "]", "_")
                cleanOrig = Replace(cleanOrig, "/", "_")
                cleanOrig = Replace(cleanOrig, "\", "_")
                cleanOrig = Replace(cleanOrig, ":", "_")
                cleanOrig = Replace(cleanOrig, "?", "_")
                cleanOrig = Replace(cleanOrig, "*", "_")
                cleanOrig = Replace(cleanOrig, vbTab, "_")
                cleanOrig = Replace(cleanOrig, ",", "_")
                cleanOrig = Replace(cleanOrig, ";", "_")
                cleanOrig = Replace(cleanOrig, ".", "_")
                
                ' Entferne explizit vorkommendes "_VORLAGE_" aus dem Parameternamen
                cleanOrig = Replace(cleanOrig, "_VORLAGE_betrieb_", "")
                cleanOrig = Replace(cleanOrig, "_VORLAGE_setup_", "")
                
                ' Zusammensetzen des Kandidaten
                candidate = cleanSheet & "_" & cleanOrig
                
                ' Sicherstellen, dass Name nicht mit Zahl beginnt
                If Len(candidate) > 0 Then
                    If IsNumeric(Left(candidate, 1)) Then
                        candidate = "_" & candidate
                    End If
                End If
                
                ' MsgBox-Ausgabe (optional, du hattest das gewünscht)
                'MsgBox "Name (neu): " & candidate & vbCrLf & _
                       "Bereich: " & sheetName & vbCrLf & _
                       "Bezieht sich auf: " & refers, vbInformation, "Wird ersetzt"
                       
                
                ' Prüfen ob Name bereits existiert; falls ja, Suffix anhängen
                suffix = 0
TryUnique:
                exists = False
                For Each nmCheck In wb.Names
                    If StrComp(nmCheck.Name, candidate, vbTextCompare) = 0 Then
                        exists = True
                        Exit For
                    End If
                Next nmCheck
                If exists Then
                    suffix = suffix + 1
                    candidate = cleanSheet & "_" & cleanOrig & "_" & suffix
                    GoTo TryUnique
                End If
                
                ' Versuchen, neuen globalen Namen anzulegen
                On Error Resume Next
                wb.Names.Add Name:=candidate, RefersTo:=refers, Visible:=vis
                addErr = Err.Number
                addErrDesc = Err.Description
                On Error GoTo 0
                
                If addErr = 0 Then
                    ' erfolgreich: lokalen Namen löschen und in Debug protokollieren
                    On Error Resume Next
                    localNm.Delete
                    If Err.Number <> 0 Then
                        dbgSheet.Cells(nextRow, 1).Value = "Fehler beim Löschen: " & Err.Description
                        Err.Clear
                    Else
                        dbgSheet.Cells(nextRow, 1).Value = "OK"
                    End If
                    On Error GoTo 0
                    dbgSheet.Cells(nextRow, 2).Value = origName
                    dbgSheet.Cells(nextRow, 3).Value = candidate
                    dbgSheet.Cells(nextRow, 4).Value = sheetName
                    dbgSheet.Cells(nextRow, 5).Value = refers
                    nextRow = nextRow + 1
                Else
                    ' Fehler beim Anlegen: Debug protokollieren und zweiten Versuch starten
                    dbgSheet.Cells(nextRow, 1).Value = "Fehler Add: " & addErrDesc
                    dbgSheet.Cells(nextRow, 2).Value = origName
                    dbgSheet.Cells(nextRow, 3).Value = candidate
                    dbgSheet.Cells(nextRow, 4).Value = sheetName
                    dbgSheet.Cells(nextRow, 5).Value = refers
                    
                    ' stärkere Bereinigung: nur A-Z,a-z,0-9,_
                    tmp = ""
                    For j = 1 To Len(candidate)
                        ch = Mid(candidate, j, 1)
                        If ch Like "[A-Za-z0-9_]" Then
                            tmp = tmp & ch
                        Else
                            tmp = tmp & "_"
                        End If
                    Next j
                    If Len(tmp) = 0 Then tmp = "name_" & CStr(Application.WorksheetFunction.RandBetween(1000, 9999))
                    tmpCandidate = tmp
                    ' sicherstellen, dass es nicht mit Zahl anfängt
                    If IsNumeric(Left(tmpCandidate, 1)) Then tmpCandidate = "_" & tmpCandidate
                    
                    ' Einmaliger Suffix-Test zur Sicherheit
                    suffix = 0
RetryAdd:
                    exists = False
                    For Each nmCheck In wb.Names
                        If StrComp(nmCheck.Name, tmpCandidate, vbTextCompare) = 0 Then
                            exists = True
                            Exit For
                        End If
                    Next nmCheck
                    If exists Then
                        suffix = suffix + 1
                        tmpCandidate = tmp & "_" & suffix
                        GoTo RetryAdd
                    End If
                    
                    On Error Resume Next
                    wb.Names.Add Name:=tmpCandidate, RefersTo:=refers, Visible:=vis
                    addErr = Err.Number
                    addErrDesc = Err.Description
                    On Error GoTo 0
                    
                    If addErr = 0 Then
                        ' erfolgreich: lokal löschen und Debug aktualisieren
                        On Error Resume Next
                        localNm.Delete
                        If Err.Number <> 0 Then
                            dbgSheet.Cells(nextRow, 1).Value = "Fehler beim Löschen (2): " & Err.Description
                            Err.Clear
                        Else
                            dbgSheet.Cells(nextRow, 1).Value = "OK (2)"
                        End If
                        On Error GoTo 0
                        dbgSheet.Cells(nextRow, 3).Value = tmpCandidate ' aktualisiere neuen Namen in Debug
                        nextRow = nextRow + 1
                    Else
                        ' endgültiges Scheitern: lokal NICHT löschen, Debug-Eintrag bereits vorhanden
                        dbgSheet.Cells(nextRow, 1).Value = "ENDGÜLTIGER FEHLER: " & addErrDesc
                        nextRow = nextRow + 1
                    End If
                End If
            Next i
        End If
        
       
NextSheet:
    Next ws

    MsgBox "Fertig: Vorgang abgeschlossen. Details im Blatt 'debug'.", vbInformation, "Fertig"

FinallyClean:
    ' Events / Bildschirm aktualisierung zurücksetzen
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
Abgerufen von „https://lhlab.wiki/index.php?title=Excel_Makro_Script_Parameter_Typ_ändern&oldid=10305“