Zum Inhalt springen

Excel Makro Script Parameter auf Blatt umbenennen

Aus LHlab Wiki

Folgendes Script benennt alle Parameter auf einem Blatt um, inkl. der Zellbezüge bzw. Verwendung in Formeln.

  • Es werden alle Parameter mit "_VORLAGE_betrieb" oder "_VORLAGE_setup" im Namen umbenannt
  • Der neue Name Setzt sich wie folgt zusammen: <blatt><parametername>
Sub Start_ErsetzeVorlageMitBlattname_ohneAt()
    Dim ws As Worksheet
    Dim rng As Range, c As Range
    Dim f As String
    Dim Blattname As String
    Dim Suchtext_Betrieb As String
    Dim Suchtext_Setup As String
    Dim countReplaced As Long
 
    ' Aktuelles Blatt und Zieltext
    Set ws = ActiveSheet
    Blattname = Replace(ws.Name, " ", "_")
    Suchtext_Betrieb = "_VORLAGE_betrieb"
    Suchtext_Setup = "_VORLAGE_setup"
 
    On Error Resume Next
    Set rng = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
 
    If rng Is Nothing Then
        MsgBox "Keine Formeln im Blatt '" & Blattname & "' gefunden.", vbInformation
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    countReplaced = 0
 
    For Each c In rng.Cells
        'f = CStr(c.FormulaR1C1)
        f = CStr(c.Formula2)
        If InStr(1, f, Suchtext_Betrieb, vbTextCompare) > 0 Then
            'c.FormulaR1C1 = Replace(f, Suchtext_Betrieb, Blattname, 1, -1, vbTextCompare)
            c.Formula2 = Replace(f, Suchtext_Betrieb, Blattname, 1, -1, vbTextCompare)
            countReplaced = countReplaced + 1
        End If
        
        If InStr(1, f, Suchtext_Setup, vbTextCompare) > 0 Then
            'c.FormulaR1C1 = Replace(f, Suchtext_Setup, Blattname, 1, -1, vbTextCompare)
            c.Formula2 = Replace(f, Suchtext_Setup, Blattname, 1, -1, vbTextCompare)
            countReplaced = countReplaced + 1
        End If
    Next c
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox countReplaced & " Formeln angepasst im Blatt '" & Blattname & "'.", vbInformation
    
End Sub