19.05.2019, 12:51
(Dieser Beitrag wurde zuletzt bearbeitet: 19.05.2019, 13:01 von WillWissen.
Bearbeitungsgrund: Codetags
)
Hallo zusammen,
nachdem ich jetzt mehrere Tage verbracht habe den Fehler zu finden, wende ich mich an Euch in der Hoffnung das mir jemand helfen kann.
Wahrscheinlich bin ich nur zu Blind...
Ich habe ein Makro in Excel welches mir einen automatischen Seriendruck anstößt.
Innerhalb des Makros sind diverse Formatierungen festgelegt die dem Drucksheet sagen was zu drucken ist.
Nun ist es aber so, dass wenn der Preis in Euro mit z.B. ,90 oder, 80 endet ist die letzte Null nicht mit auf dem Ausdruck.
Die muss aber zwingend mit auf den Ausdruck.
Hier mal das Makro
Ich hoffe das wer helfen kann.
Danke
nachdem ich jetzt mehrere Tage verbracht habe den Fehler zu finden, wende ich mich an Euch in der Hoffnung das mir jemand helfen kann.
Wahrscheinlich bin ich nur zu Blind...
Ich habe ein Makro in Excel welches mir einen automatischen Seriendruck anstößt.
Innerhalb des Makros sind diverse Formatierungen festgelegt die dem Drucksheet sagen was zu drucken ist.
Nun ist es aber so, dass wenn der Preis in Euro mit z.B. ,90 oder, 80 endet ist die letzte Null nicht mit auf dem Ausdruck.
Die muss aber zwingend mit auf den Ausdruck.
Hier mal das Makro
Code:
Sub Seriendruck1()
For a = 1 To Sheets("Drucktabelle").Cells(1, 1).End(xlDown).Row
Sheets("Druckvorlage").Cells(2, 6).Value = CStr(Sheets("Drucktabelle").Cells(a, 1))
Sheets("G+").Cells(1, 1).Value = CStr(Sheets("Drucktabelle").Cells(a, 2))
Sheets("G+").Cells(1, 2).Value = CStr(Sheets("Drucktabelle").Cells(a, 3))
Sheets("G+").Cells(1, 3).Value = CStr(Sheets("Drucktabelle").Cells(a, 7))
Sheets("Druckvorlage").Activate
Sheets("Druckvorlage").Cells(36, 1).Value = CStr(Sheets("Druckvorlage").Cells(3, 6))
Range("B36").Select
Dim listrWert As String
Selection.NumberFormat = "@"
listrWert = ActiveCell.Value
With Selection
.HorizontalAlignment = xlCenter
End With
ActiveCell.FormulaR1C1 = listrWert
Select Case Len(ActiveCell.Value)
Case 5
With ActiveCell.Characters(Start:=1, Length:=3).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=4, Length:=2).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
Case 6
With ActiveCell.Characters(Start:=1, Length:=2).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=3, Length:=2).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=6, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
Case 7
With ActiveCell.Characters(Start:=1, Length:=3).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=4, Length:=3).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=7, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
Case 8
With ActiveCell.Characters(Start:=1, Length:=4).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=5, Length:=3).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=8, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
Case 9
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=6, Length:=3).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=9, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
Case 10
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=7, Length:=3).Font
.Name = "Eurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=10, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
Case 11
With ActiveCell.Characters(Start:=1, Length:=7).Font
.Name = "Eurostile OT Black"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=8, Length:=3).Font
.Name = "PEurostile OT Black"
.Size = 60
.Superscript = True
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=11, Length:=1).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 170
.Color = RGB(239, 124, 0)
End With
End Select
Selection.NumberFormat = "0.00"
Sheets("Druckvorlage").Cells(47, 7).Value = CStr(Sheets("Druckvorlage").Cells(4, 6))
If Cells(47, 7).Value Like "" Then
Else
ActiveSheet.Shapes.AddLine(450, 780, 550, 830).Select
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Weight = 4#
Selection.ShapeRange.Name = "Linie1"
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
ActiveSheet.Shapes.AddLine(450, 830, 550, 780).Select
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Weight = 4#
Selection.ShapeRange.Name = "Linie2"
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
End If
Range("h47").Select
Dim listrWert2 As String
Selection.NumberFormat = "@"
listrWert2 = ActiveCell.Value
With Selection
.HorizontalAlignment = xlRight
End With
ActiveCell.FormulaR1C1 = listrWert2
Select Case Len(ActiveCell.Value)
Case 5
With ActiveCell.Characters(Start:=1, Length:=3).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 48
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=4, Length:=2).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 24
.Superscript = True
.Color = RGB(239, 124, 0)
End With
Case 6
With ActiveCell.Characters(Start:=1, Length:=4).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 48
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=5, Length:=2).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 24
.Superscript = True
.Color = RGB(239, 124, 0)
End With
Case 7
With ActiveCell.Characters(Start:=1, Length:=5).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 48
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=6, Length:=2).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 24
.Superscript = True
.Color = RGB(239, 124, 0)
End With
Case 8
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 48
.Color = RGB(239, 124, 0)
End With
With ActiveCell.Characters(Start:=7, Length:=2).Font
.Name = "Presto_Franklin Gothic Demi Con"
.FontStyle = "Standard"
.Size = 24
.Superscript = True
.Color = RGB(239, 124, 0)
End With
End Select
Selection.NumberFormat = "0.00"
If Cells(2, 6).Value Like "ArtNr." Then
Else
Dim Druck As Integer
Druck = Worksheets("Drucktabelle").Range("q13").Value
For b = 1 To Druck
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Next b
End If
Dim Shl1 As Object
For Each Shl1 In ActiveSheet.Shapes
If Shl1.Name = "Linie1" Then
Shl1.Delete
End If
Next
Dim Shl2 As Object
For Each Shl2 In ActiveSheet.Shapes
If Shl2.Name = "Linie2" Then
Shl2.Delete
End If
Next
Next a
Sheets("Drucktabelle").Activate
End Sub
Ich hoffe das wer helfen kann.
Danke