Einen kühlen guten Tag!
Bei den Temp. nach zu denken ist nicht leicht, aber dann noch über anderer Leuts Sorgen ... na ja vielleicht klappt da doch noch was:
Per VBA habe ich eine Exceltabelle erzeugen lassen, die mir neben der lfd. Nummer den Namen eine eine beliebige Schriftprobe in beliebiger Größe erzeugt.
Wenn ich aber die eine oder andere Schriftart z.B in der Größe in der Tabelle ändern möchte erscheint folgende mir unbekannte Meldung von EXCEL:
"Keine weiteren neuen Schriftarten dürfen hinzugefügt werden. Schließen Sie andere Dokumente und wiederholen Sie den Vorgang."
Änderungen z. B. an der Größe sind unsinnig, da ein größer zu kleineren und ein kleiner auch zu größeren Schriften führt :-( Ich bin da völlig ratlos und vermute in der VBA einen gravierenden Fehler gemacht zu haben.
Hier ein Ausschnitt:
Private Sub CommandButton1_Click() 'Start
Dim z As Long
Dim start As String
Dim SchriftNr, ix, x As Integer, Schriftliste As Object
Set Schriftliste = Application.CommandBars("formatting").FindControl(ID:=1728)
start = Time
On Error Resume Next
Application.ScreenUpdating = False
'[A:C].ClearContents
Application.StatusBar = "In Arbeit: "
ix = 1
For SchriftNr = 0 To Schriftliste.ListCount - 1
Cells(SchriftNr + 1, 1).Value = SchriftNr + 1
Cells(SchriftNr + 1, 2).Value = Schriftliste.List(SchriftNr + 1)
Cells(SchriftNr + 1, 3).Value = UserForm1.TextBox2
Cells(SchriftNr + 1, 3).Font.Name = Schriftliste.List(SchriftNr + 1)
Cells(SchriftNr + 1, 3).Font.Size = Val(UserForm1.TextBox1)
'Range("B" & SchriftNr + 1).Font.Size = 24 'Val(UserForm1.TextBox1)
UserForm1.Label6 = SchriftNr
If ix < 120 Then
Application.StatusBar = Application.StatusBar & "#"
ix = ix + 1
Else
ix = 1
Application.StatusBar = "In Arbeit: "
End If
DoEvents
Next
Application.ScreenUpdating = True
Range("B1").Select
Selection.EntireRow.Insert
ActiveCell.FormulaR1C1 = "N A M E"
Selection.Font.Bold = True
Range("C1").Select
ActiveCell.FormulaR1C1 = "S C H R I F T E N M U S T E R"
Selection.Font.Bold = True
Range("A1").Select
ActiveCell.FormulaR1C1 = "L f d - N r."
Selection.Font.Bold = True
Range("B1").Select
Range("A1:C1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Rows("1:1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
Range("A1").Select
Application.StatusBar = "S C H R I F T E N L I S T E W U R D E E R S T E L L T !"
UserForm2.Caption = "Start: " & start & " -> Ende: " & Time 'Initialisierung
UserForm2.Show
UserForm2.Caption = "Start: " & start & " -> Ende: " & Time
Unload UserForm2
Application.DisplayFormulaBar = True ' Bearbeitungsleiste sichtbar
Unload UserForm1
Es wäre schön wenn ein Spezialist das "Machwerk" begutachten könnte. Ich bin mir auch im Klarem, dass nicht alles "effektiv" ist, aber seis drum, es macht mir Spaß und Freude.
Schon jetzt vielen Dank an den/die Spezialisten.
|