VBA-Skript auf alle Tabellenblätter beziehen
24.03.2017 15:33:04
Denis
ich hoffe, ihr könnt mir bei folgendem Problem helfen.
Ich habe Excel-Dateien, in denen ein über VBA programmiertes Makro geschrieben wurde (nicht von mir).
Es geht um einen Speiseplan, der aus unserem WaWi-System exportiert wird. Wenn die Datei geöffnet wird, schaltet das Makro und stellt bei den Gerichten die Allergene und Zusatzstoffe hoch.
In anderen Tabellenblättern habe ich z.B. Tagesaushänge, wo einfach nur normale Verknüpfungen zum Speiseplan-Blatt sind (z.B. =Speiseplan!B12).
Das Makro hat bisher die Allergene und Zusatzstoffe in allen Tabellenblättern hochgestellt, auch in den Verknüpfungen (obwohl ich gelesen hatte, dass Formatierungen nicht bei Verknüpfungen übernommen werden).
Nun musste von unserer IT-Abteilung meine Office-Umgebung auf Deutsch umgestellt werden (vorher Englisch) und plötzlich funktioniert dieses Makro nicht mehr.
Es stellt nur noch die Zeichen im Speiseplan-Blatt hoch, nicht mehr in den Tagesaushängen.
Was genau ist da passiert, und was muss ich ändern, damit es wieder funktioniert?
Hier das Skript aus VBA:
Private
Sub Workbook_Open()
Application.CalculateFull
If ActiveWorkbook.Worksheets("Daten").Range("B11").Value = "1" Then
FormatIngridients
Function FormatIngridients()
' Deklarationsteil
Const startTag = "#MBS"
Const endTag = "MBS#"
Dim foundCell As Range
Dim blattzahl As Integer
' Erste Zelle auswählen damit die Suche
' funktioniert und alle möglichen Zellen findet
blattzahl = ActiveWorkbook.Sheets.Count
blattzahl = blattzahl - 3
For i = 1 To blattzahl
ActiveWorkbook.Worksheets(i).Activate
' Erste Zelle suchen
Set foundCell = Cells.Find(startTag, After:=Range("A1"), LookIn:=xlValues, LookAt:=XlLookAt. _
xlPart)
Do
If Not foundCell Is Nothing Then
' Formelwert in Zelle übernehmen
foundCell.FormulaR1C1 = foundCell.Value
' Indices für die Inhaltsstoffe
Dim startIndex As Integer
Dim endIndex As Integer
' Liste für die Indizes zum Hochstellen
Dim indexList() As Integer
Dim ind As Integer ' Index
' Ersten Startindex zuweisen
startIndex = InStr(1, foundCell.Value, startTag, vbTextCompare)
ReDim indexList(1)
indexList(1) = startIndex
' Innere Schleife zur Textformatierung und Ersetzung der Markierungen
Do While Not startIndex = 0
' Bei erstem Schleifendurchlauf, darf Startindex noch nicht zugewiesen werden
If Not UBound(indexList) = 1 Then
ind = UBound(indexList)
ReDim Preserve indexList(ind + 1)
' Startindex übernehmen
indexList(ind + 1) = startIndex
End If
' StartTag entfernen - Zur Berechnung des korrekten EndIndex
foundCell.Value = Replace(foundCell.Value, startTag, "", 1, 1)
' EndTag suchen
If endIndex = 0 Then
endIndex = InStr(1, foundCell.Value, endTag, vbTextCompare)
Else
endIndex = InStr(startIndex, foundCell.Value, endTag, vbTextCompare)
End If
ind = UBound(indexList)
ReDim Preserve indexList(ind + 1)
' Endindex übernehmen
indexList(ind + 1) = endIndex
' Endtag entfernen
foundCell.Value = Replace(foundCell.Value, endTag, "", 1, 1)
' Nächsten StartTag suchen
startIndex = InStr(endIndex, foundCell.Value, startTag, vbTextCompare)
Loop ' Ende Schleife: "Indices für hochgestelltes formatieren ermitteln"
' Hochgestellte Zusatzstoffe nach Ersetzung der Tags
For x = 1 To UBound(indexList) - 1 Step 2 ' In 2er-Schritten, da immer Start (1) / _
Endindex (2), usw.
st = indexList(x) 'Startindex
ende = indexList(x + 1) 'Endindex
With foundCell.Characters(st, ende - st).Font
.Superscript = True
End With
Next x
' Speicherfreigabe der IndexListe
Erase indexList()
' Nächste Zelle zuweisen
Set foundCell = Cells.FindNext(After:=foundCell)
End If ' Ende If foundCell != null
Loop While Not foundCell Is Nothing ' Ende Schleife: "nach Zellen suchen"
Next i
End Function
Ich hoffe auf eure Hilfe und bedanke mich im Voraus!
Viele Grüße,
Denis L.