|
Morgen Zusammen,
Vorerst möchste ich sagen, dass ich nicht soviel erfahrung habe mit VBA und glaube das mein Problem/Wunsch leicht zu lösen ist.
Das Makro steht schon und ich glaube man muss nur wenig was ändern .
Das ist aktuell die Formel. wenn ich die Zahl 40 eingebe, wird es immer in 40er schritten ausgedruckt(Weil die Excel Datei mehr als 40 Zahlen hat)
Bsp: 100 Zahlen.
Eingabe: 40
Ergebnis= 1 Blatt 40 Zahlen
2 Blatt 40 Zahlen
3 Blatt 20 Zahlen
Ich würde gerne aber das es so ausgedruckt wird : 1 Blatt 80 Zahlen
2 Blatt 10 Zahlen
3 Blatt 10 Zahlen
Dazu muss ich sagen, dass es manchmal auch mehr Zahlen in der Excel Datei stehen bsp:250 aber es soll trotzdem zuerst 80,10, 10 pro Blatt und der Rest auf den Nächten Blatt ausgedruckt werden.
Also ich würde gerne, selber jedes mal im InputBox entscheiden in welchen Schriten es ausgedruckt werden soll
Ich hoffe man konnte es etwas verstehen.
Formel :
Dim Menge
Dim XXAMin
Dim XXBMax
Dim Runde
Dim RundeI
Dim zahl
Sheets("Blatt1").Select
' setzt Filter um ihn nachher löschen zu können
ActiveSheet.Range("A2:A1000").AutoFilter Field:=1, Criteria1:="<=" & 1000
' Löscht Filter
ActiveSheet.ShowAllData
' Ermittlung der letzten Zeile
Dim Ende As Long
With ActiveSheet
Ende = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
' Löscht bedingte Formatierung in Spalte A
Range("A3:C" & Ende).Select
Selection.FormatConditions.Delete
' Ermittelt Anzahl der Zahlen
KLT = Range("A" & Ende).Value
' Summe der Zahlen pro Runde
Range("H1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(109,R[8]C:R[9999]C)"
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Menge = InputBox("Bitte Zahl eingeben" & vbCrLf & "Zum Drucken OK wählen", "Drucken", 40)
If Menge = "" Then
GoTo EndPrint
Else
'
Runde = Application.RoundUp((zahl + 10) / Menge, 0)
'Runde = 100
XXAMin = 0
For RundeI = 1 To Runde
Sheets("Blatt1").Select
XXBMax = Menge + XXAMin
ActiveSheet.Range("A2:S" & Ende).AutoFilter Field:=1, Criteria1:="<=" & XXBMax, _
Operator:=xlAnd, Criteria2:=">" & XXAMin
ActiveSheet.Range("A2:S" & Ende).AutoFilter Field:=3, Criteria1:="<=" & XXBMax, _
Operator:=xlOr, Criteria2:="="
XXBMax = Cells(1, 8) + XXAMin
' Hilfsspalte für Schattierung der ersten Spalte je Runde
Columns("Q:Q").Select
Selection.EntireColumn.Hidden = False
Range("Q3:Q" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells(1).Select
Range("Q3:Q" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells.Select
ActiveCell.FormulaR1C1 = RundeI
If XXBMax - XXAMin <> 1 Then
Selection.FillDown
End If
Columns("Q:Q").Select
Selection.EntireColumn.Hidden = True
' ----------------------
Range("F1").Select
ActiveCell.FormulaR1C1 = "batt2 - Runde " & RundeI
Selection.Font.Bold = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Sheets("Blatto").Select
ActiveSheet.Range("A2:S" & Ende).AutoFilter Field:=1, Criteria1:="<=" & XXBMax, _
Operator:=xlAnd, Criteria2:=">" & XXAMin
Range("F1").Select
ActiveCell.FormulaR1C1 = "batt3 - Runde " & RundeI
Selection.Font.Bold = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
If XXBMax = zahl Then
GoTo EndPrint
End If
XXAMin = XXBMax
Next RundeI
End If
EndPrint:
Sheets("Blatto").Select
' setzt Filter um ihne nachher löschen zu können
ActiveSheet.Range("A2:A1000").AutoFilter Field:=1, Criteria1:="<=" & 1000
' Löscht Filter
ActiveSheet.ShowAllData
Sheets("Blatt1").Select
' setzt Filter um ihne nachher löschen zu können
ActiveSheet.Range("A2:A1000").AutoFilter Field:=1, Criteria1:="<=" & 1000
' Löscht Filter
ActiveSheet.ShowAllData
'
If Menge = "" Then
GoTo EndSub
Else
Range("A3:A" & Ende).Select
Range("A3").Activate
'Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISTGERADE(AUFRUNDEN(A3 /" & Menge & "; 0))"
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ISTGERADE(Q3)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.14996795556505
End With
End If
EndSub:
|