share it if you like it
share it if you like it
share it if you like it
Die Excel Wühlkiste

Papiersortenberechnung

undokumentiert
Hier ein echtes "Wühltisch-Teil". Eine Dokumentation oder sogar das ganze Projekt zum Download dazu wird es nicht geben. Dennoch gibt es einige interessante Bestandteile.
   Zum Beispiel das automatische Eintragen einer Formel in eine Tabellenzelle mit FormulaLocal, bzw. die Benutzung Excel eigener Funktionen zur schnelleren Berechnung, als dies über VBA-Berechnung in einer Schleifenstruktur möglich wäre. Spannend hierbei ist, dass wegen der großen Datenmenge der Geschwindigkeitsvorteil ganz klar auf die BuildIn´s fällt. Siehe dazu: Kommentar

 

 
Weitere Bestandteile sind:
- AutoFilterMode; SUMMENPRODUKT; FormulaArray
- FREQUENCY; SUBTOTAL; OFFSET
- INDIREKT; TEILERGEBNIS; ActiveCell.Address
- ZÄHLENWENN; ClearContents; Sort ...
um nur einige zu nennen.

  Modul 1     Modul 2     Modul 3  
  Modul 4     Modul 5     Modul 6  

  CommandButtons     Menue  
Modul 1
Option Explicit

Sub DatenHolen()
Dim Ende1, Ende4, Ende5, Ende6 As Long
Dim Position As String
Dim Beenden As Boolean

' Tabellenstrukturprüfung
Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Ende1 = Worksheets("Wellenkaliber").Range("Laenge1").Value
Ende4 = Worksheets("Wellenkaliber").Range("Laenge4").Value
Ende5 = Worksheets("Wellenkaliber").Range("Laenge5").Value
Ende6 = Worksheets("Wellenkaliber").Range("Laenge6").Value

' Prüfung, ob Daten vorhanden sind
If Ende1 = 4 Then
MsgBox ("Diese Liste enthält keine Daten")
Exit Sub
End If


Worksheets("Auftrag").Activate
Position = ActiveCell.Address

' Autofilter aus
If Worksheets("Auftrag").AutoFilterMode = True Then
    Worksheets("Auftrag").AutoFilterMode = False
    Worksheets("Auftrag").Rows("4:4").AutoFilter
End If

' alte Daten löschen
Range(Cells(5, 4), Cells(Ende1 + 5, 50)).ClearContents

Application.ScreenUpdating = False
Range("B2:B3").ClearContents
Range("Z2:Z3").ClearContents
Range("X3").ClearContents
Range("AU3").ClearContents

Range("A1").Select
Kommentar
nach oben
' Der Test hat ergeben, dass aufgrund der Datenmenge eine Berechnung der
' einzelnen Zellen über eine Schleifenstruktur im VBA-Modul erheblich
' länger dauert, als folgende Methode:
' in der ersten Zeile des zu berechnenden Datenbereichs werden die Formeln
' geschrieben. Anschließend werden diese Formeln per "Copy and Past"
' in alle zu berechnenden Zellen kopiert. Dann werden die Formeln
' durch die berechneten Werte ersetzt.
' Die Excel eigenen Methoden zum Kopieren und Inhalte einfügen laufen
' wesentlich schneller ab, als reiner VBA Code.
Ende Kommentar
nach oben
'Daten P912
Range("D5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";3;Falsch)"
Range("E5").FormulaLocal = "=SVERWEIS(D5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("F5").FormulaLocal = "=SVERWEIS(D5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("G5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";5;FALSCH)"
Range("H5").FormulaLocal = "=SVERWEIS(G5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("I5").FormulaLocal = "=SVERWEIS(G5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("J5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";7;FALSCH)"
Range("K5").FormulaLocal = "=SVERWEIS(J5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("L5").FormulaLocal = "=SVERWEIS(J5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("M5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";9;FALSCH)"
Range("N5").FormulaLocal = "=SVERWEIS(M5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("O5").FormulaLocal = "=SVERWEIS(M5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("P5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";11;FALSCH)"
Range("Q5").FormulaLocal = "=SVERWEIS(P5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("R5").FormulaLocal = "=SVERWEIS(P5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("S5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";16;FALSCH)"
Range("T5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";17;FALSCH)"
Range("U5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";13;FALSCH)/100"
Range("V5").FormulaLocal = "=U5*C5"
Range("W5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$S$" & Ende4 & ";19;FALSCH)"
Range("X5").FormulaLocal = "=SVERWEIS($B5;'p912'!$A$2:$Q$" & Ende4 & ";14;FALSCH)"

Range(Cells(5, 2), Cells(Ende1, 2)).Copy
Range(Cells(5, 26), Cells(Ende1, 26)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Range(Cells(5, 4), Cells(5, 24)).Copy
Range(Cells(6, 4), Cells(Ende1, 24)).PasteSpecial (xlPasteFormulas)
Application.CutCopyMode = False

Range(Cells(5, 4), Cells(Ende1, 24)).Copy
Range(Cells(5, 4), Cells(Ende1, 24)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

'Application.ScreenUpdating = True
'Range("Z5").Select
'Application.ScreenUpdating = False

'P994
Range("AA5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";3;Falsch)"
Range("AB5").FormulaLocal = "=SVERWEIS(AA5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("AC5").FormulaLocal = "=SVERWEIS(AA5;Papierpreise!$A$3:$C$203;3;FALSCH)"
Range("AD5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";5;FALSCH)"
Range("AE5").FormulaLocal = "=SVERWEIS(AD5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("AF5").FormulaLocal = "=SVERWEIS(AD5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("AG5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";7;FALSCH)"
Range("AH5").FormulaLocal = "=SVERWEIS(AG5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("AI5").FormulaLocal = "=SVERWEIS(AG5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("AJ5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";9;FALSCH)"
Range("AK5").FormulaLocal = "=SVERWEIS(AJ5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("AL5").FormulaLocal = "=SVERWEIS(AJ5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("AM5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";11;FALSCH)"
Range("AN5").FormulaLocal = "=SVERWEIS(AM5;Papierpreise!$A$3:$C$" & Ende6 & ";2;FALSCH)"
Range("AO5").FormulaLocal = "=SVERWEIS(AM5;Papierpreise!$A$3:$C$" & Ende6 & ";3;FALSCH)"
Range("AP5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";16;FALSCH)"
Range("AQ5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";17;FALSCH)"
Range("AR5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";13;FALSCH)/100"
Range("AS5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$S$" & Ende5 & ";19;FALSCH)"
Range("AT5").FormulaLocal = "=(AS5-W5)/W5"
Range("AU5").FormulaLocal = "=SVERWEIS($Z5;'p994'!$A$2:$Q$" & Ende5 & ";14;FALSCH)"
Range("AV5").FormulaLocal = "=(AR5-U5)*C5"

Range(Cells(5, 27), Cells(5, 48)).Copy
Range(Cells(6, 27), Cells(Ende1, 48)).PasteSpecial (xlPasteFormulas)
Application.CutCopyMode = False

' dieser Block ist auskommentiert, da der Anwender die Formeln
' in diesem Tabellenbereich behalten wollte, um schnell Ergebnisse
' nach manuellen Änderungen der Daten zu bekommen, ohne die komplette
' Prozedur starten zu müssen:
'Range(Cells(5, 27), Cells(Ende1, 48)).Copy
'Range(Cells(5, 27), Cells(Ende1, 48)).PasteSpecial (xlPasteValues)
'Application.CutCopyMode = False
'Range("Z5").Select

Range("AW5").FormulaLocal = "=SVERWEIS(S5;Wellenkaliber!$A$2:$B$6;2;FALSCH)"
Range("AX5").FormulaLocal = "=SVERWEIS(T5;Wellenkaliber!$A$2:$B$6;2;FALSCH)"

Range(Cells(5, 49), Cells(5, 50)).Copy
Range(Cells(6, 49), Cells(Ende1, 50)).PasteSpecial (xlPasteFormulas)
Application.CutCopyMode = False

Range(Cells(5, 49), Cells(Ende1, 50)).Copy
Range(Cells(5, 49), Cells(Ende1, 50)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
'Range("A3").Select

'Range("X3").FormulaLocal = "=SUMMENPRODUKT(X5:X" & Ende1 & "*C5:C" & Ende1 & ")/1000000"
Range("X3").FormulaLocal = "=SUMMENPRODUKT(TEILERGEBNIS(6;INDIREKT(""X""&ZEILE(5:" & Ende1 & ")));C5:C" & Ende1 & ")/1000000"
'Range("AU3").FormulaLocal = "=SUMMENPRODUKT(AU5:AU" & Ende1 & "*C5:C" & Ende1 & ")/1000000"
Range("AU3").FormulaLocal = "=SUMMENPRODUKT(TEILERGEBNIS(6;INDIREKT(""AU""&ZEILE(5:" & Ende1 & ")));C5:C" & Ende1 & ")/1000000"

' Besonderheit: man achte auf die RC Addressierung der Bezüge in den Arrayformeln
Range("B2").FormulaArray = _
    "=COUNT(1/FREQUENCY(IF((SUBTOTAL(3,OFFSET(R5C,ROW(R5C:R" & Ende1 & "C)-ROW(R5C),0))=1)*(R5C:R" & Ende1 & "C<>""""),MATCH(R5C:R" & Ende1 & "C,R5C:R" & Ende1
      & "C,0)),ROW(INDIRECT(""1:""&COUNTA(R5C:R" & Ende1 & "C)))))"
Range("Z2").FormulaArray = _
    "=COUNT(1/FREQUENCY(IF((SUBTOTAL(3,OFFSET(R5C,ROW(R5C:R" & Ende1 & "C)-ROW(R5C),0))=1)*(R5C:R" & Ende1 & "C<>""""),MATCH(R5C:R" & Ende1 & "C,R5C:R" & Ende1
      & "C,0)),ROW(INDIRECT(""1:""&COUNTA(R5C:R" & Ende1 & "C)))))"
Range("B3").FormulaArray = _
    "=SUM(IF(R5C:R" & Ende1 & "C<>"""",1/COUNTIF(R5C:R" & Ende1 & "C,R5C:R" & Ende1 & "C)))"
Range("Z3").FormulaArray = _
    "=SUM(IF(R5C:R" & Ende1 & "C<>"""",1/COUNTIF(R5C:R" & Ende1 & "C,R5C:R" & Ende1 & "C)))"
Range("C3").FormulaLocal = "=TEILERGEBNIS(9;C5:C" & Ende1 & ")"
Range("V3").FormulaLocal = "=TEILERGEBNIS(9;V5:V" & Ende1 & ")"
Range("W3").FormulaLocal = "=(SUMMENPRODUKT(TEILERGEBNIS(6;INDIREKT(""W""&ZEILE(5:" & Ende1 & ")));C5:C" & Ende1 & ")/C3)"
Range("AS3").FormulaLocal = "=(SUMMENPRODUKT(TEILERGEBNIS(6;INDIREKT(""AS""&ZEILE(5:" & Ende1 & ")));C5:C" & Ende1 & ")/C3)"
Range("AV3").FormulaLocal = "=TEILERGEBNIS(9;AV5:AV" & Ende1 & ")"


Range(Position).Activate
Application.ScreenUpdating = True

MsgBox ("Daten komplett übertragen")

End Sub
Modul 2
nach oben
Option Explicit

Sub Analyse()
Dim SortenNr(1001), Beenden As Boolean
Dim I As Long
Dim X As Integer
Dim Ende1, Ende2, Ende3, Ende4, Ende5, Ende6 As Long
Dim A, B, C, D, E, F, SFqm, SFTonnen, Position As String
Dim Diff As Integer
Dim Summe(8) As String

Call Abbruch(Beenden)
If Beenden = True Then Exit Sub


Ende1 = Worksheets("Wellenkaliber").Range("Laenge1").Value
Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Ende4 = Worksheets("Wellenkaliber").Range("Laenge4").Value
Ende5 = Worksheets("Wellenkaliber").Range("Laenge5").Value
Ende6 = Worksheets("Wellenkaliber").Range("Laenge6").Value

If Ende1 = 4 Then
MsgBox ("Diese Liste enthält keine Daten")
Exit Sub
End If

Application.ScreenUpdating = False

If Worksheets("Papiereinsatz").AutoFilterMode = True Then
    Worksheets("Papiereinsatz").AutoFilterMode = False
    Worksheets("Papiereinsatz").Rows("9:9").AutoFilter
        With Worksheets("Papiereinsatz").CommandButton1
        .Caption = "P994 Filter"
    End With
End If



Worksheets("Auftrag").Activate

Position = ActiveCell.Address



For I = 5 To Ende1
SortenNr(Cells(I, 4).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 7).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 10).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 13).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 16).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 27).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 30).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 33).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 36).Value) = True
Next I

For I = 5 To Ende1
SortenNr(Cells(I, 39).Value) = True
Next I


Worksheets("Papiereinsatz").Activate

'Application.ScreenUpdating = True

Range("Sortenanzahl").ClearContents
Range("H4:K4").ClearContents
Range("D4:G4").ClearContents
Range("I3").ClearContents
Range("D7:K7").ClearContents
Range(Cells(10, 1), Cells(Ende2 + 10, 11)).ClearContents

X = 10
For I = 1 To 1001
If SortenNr(I) = True Then
Worksheets("Papiereinsatz").Cells(X, 1).Value = I
X = X + 1
End If
Next

X = X - 1

'For I = 10 To X
'Worksheets("Papiereinsatz").Cells(I, 2).Value = _
'Application.WorksheetFunction. _
'VLookup(Cells(I, 1).Value, Worksheets("Papierpreise"). _
'Range("A4:D93"), 2, False)
'
'Worksheets("Papiereinsatz").Cells(I, 3).Value = _
'Application.WorksheetFunction. _
'VLookup(Cells(I, 1).Value, Worksheets("Papierpreise"). _
'Range("A4:D93"), 3, False)
'
'Next I

Worksheets("Papiereinsatz"). _
Range("B10").FormulaLocal = "=SVERWEIS($A10;'Papierpreise'!$A$4:$D$" & Ende6 & ";2;Falsch)"
Worksheets("Papiereinsatz").Range("B10").Select
'Selection.AutoFill 'Destination:=Range("B2:B45") 'Destination:=Range(Cells(10, 2), Cells(2, X))
Selection.AutoFill Destination:=Range(Cells(10, 2), Cells(X, 2))

Worksheets("Papiereinsatz"). _
Range("C10").FormulaLocal = "=SVERWEIS($A10;'Papierpreise'!$A$4:$D$" & Ende6 & ";3;Falsch)"
Worksheets("Papiereinsatz").Range("C10").Select
Selection.AutoFill Destination:=Range(Cells(10, 3), Cells(X, 3))

Range(Cells(10, 2), Cells(X, 3)).Copy
Range(Cells(10, 2), Cells(X, 3)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Range("E9").Select

'------------------------------------------------------
'Analyse Teil 2
'P912

Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Ende3 = Worksheets("Wellenkaliber").Range("Laenge3").Value

'Application.ScreenUpdating = False

A = "=(SUMMENPRODUKT((Auftrag!$D$5:$D$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
B = "+SUMMENPRODUKT((Auftrag!$J$5:$J$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
C = "+SUMMENPRODUKT((Auftrag!$P$5:$P$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "))"
D = "+SUMMENPRODUKT((Auftrag!$G$5:$G$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AW$5:$AW$" & Ende3 & ")"
E = "+SUMMENPRODUKT((Auftrag!$M$5:$M$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AX$5:$AX$" & Ende3 & ")"

'A = "=(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""D""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
'B = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""J""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
'C = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""P""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
'D = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""G""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AW$5:$AW$" & Ende3
     & ")))"
'E = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""M""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AX$5:$AX$" & Ende3
     & ")))"

SFqm = A & B & C & D & E
Range("D10").FormulaLocal = SFqm


Range("E10").FormulaLocal = "=D10/$D$9*$E$9"
Range("F10").FormulaLocal = "=D10*C10/1000000"
Range("G10").FormulaLocal = "=F10/$D$9*$E$9"

Range("E9").Select
Worksheets("Papiereinsatz").Range("D10:G10").Select
Selection.AutoFill Destination:=Range(Cells(10, 4), Cells(Ende2, 7))

Worksheets("Papiereinsatz").Range(Cells(10, 4), Cells(Ende2, 4)).Copy
Range(Cells(10, 4), Cells(Ende2, 4)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Worksheets("Papiereinsatz").Range(Cells(10, 6), Cells(Ende2, 6)).Copy
Range(Cells(10, 6), Cells(Ende2, 6)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Range("D4").Select

A = "=""P912 = ""&ZÄHLENWENN(D10:D" & Ende2 & ";"">0"")&"" Sorten"""
Range("D4").FormulaLocal = A

'----------------------------------------------------------
'P994

A = "=(SUMMENPRODUKT((Auftrag!$AA$5:$AA$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
B = "+SUMMENPRODUKT((Auftrag!$AG$5:$AG$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
C = "+SUMMENPRODUKT((Auftrag!$AM$5:$AM$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "))"
D = "+SUMMENPRODUKT((Auftrag!$AD$5:$AD$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AW$5:$AW$" & Ende3 & ")"
E = "+SUMMENPRODUKT((Auftrag!$AJ$5:$AJ$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AX$5:$AX$" & Ende3 & ")"
SFqm = A & B & C & D & E
Range("H10").FormulaLocal = SFqm


Range("I10").FormulaLocal = "=H10/$D$9*$E$9"
Range("J10").FormulaLocal = "=H10*C10/1000000"
Range("K10").FormulaLocal = "=J10/$D$9*$E$9"

Worksheets("Papiereinsatz").Range("H10:K10").Select
Selection.AutoFill Destination:=Range(Cells(10, 8), Cells(Ende2, 11))

Worksheets("Papiereinsatz").Range(Cells(10, 8), Cells(Ende2, 8)).Copy
Range(Cells(10, 8), Cells(Ende2, 8)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Worksheets("Papiereinsatz").Range(Cells(10, 10), Cells(Ende2, 10)).Copy
Range(Cells(10, 10), Cells(Ende2, 10)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

A = "=""P994 = ""&ZÄHLENWENN(H10:H" & Ende2 & ";"">0"")&"" Sorten""&""   Diff = ""&TEXT(Auftrag!AV3; ""#.##0 €"")"
Range("H4").FormulaLocal = A

Range("I3").Value = "Sortierung:" & Chr(10) & "Sorten"

Summe(0) = "=SUMME(D10:D" & Ende2 & ")"
Summe(1) = "=SUMME(E10:E" & Ende2 & ")"
Summe(2) = "=SUMME(F10:F" & Ende2 & ")"
Summe(3) = "=SUMME(G10:G" & Ende2 & ")"

Summe(4) = "=SUMME(H10:H" & Ende2 & ")"
Summe(5) = "=SUMME(I10:I" & Ende2 & ")"
Summe(6) = "=SUMME(J10:J" & Ende2 & ")"
Summe(7) = "=SUMME(K10:K" & Ende2 & ")"

Range("D7").FormulaLocal = Summe(0)
Range("E7").FormulaLocal = Summe(1)
Range("F7").FormulaLocal = Summe(2)
Range("G7").FormulaLocal = Summe(3)

Range("H7").FormulaLocal = Summe(4)
Range("I7").FormulaLocal = Summe(5)
Range("J7").FormulaLocal = Summe(6)
Range("K7").FormulaLocal = Summe(7)

Summe(8) = "=Anzahl2(A10:A" & Ende2 & ")"
Range("Sortenanzahl").FormulaLocal = Summe(8)

Range("E9").Select



Range(Position).Activate
Application.ScreenUpdating = True


MsgBox ("Berechnung ist fertig")

End Sub
Modul 3
nach oben
Option Explicit

Sub alles_löschen()
Dim Ende1, Ende2 As Long
Dim Bereich1, Bereich2 As String
Dim Beenden As Boolean

'Application.ScreenUpdating = False

Call Abbruch(Beenden)
If Beenden = True Then Exit Sub

If Worksheets("Papiereinsatz").AutoFilterMode = True Then
    Worksheets("Papiereinsatz").AutoFilterMode = False
    Worksheets("Papiereinsatz").Rows("9:9").AutoFilter
    With Worksheets("Papiereinsatz").CommandButton1
        .Caption = "P994 Filter"
    End With
End If

If Worksheets("Auftrag").AutoFilterMode = True Then
    Worksheets("Auftrag").AutoFilterMode = False
    Worksheets("Auftrag").Rows("4:4").AutoFilter
End If


Ende1 = Worksheets("Wellenkaliber").Range("Laenge1").Value
Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value

If Ende1 < 5 Then
Ende1 = 5
End If

If Ende2 < 10 Then
Ende2 = 10
End If

Bereich1 = Range(Cells(5, 4), Cells(Ende1, 50)).Address
Bereich2 = Range(Cells(10, 1), Cells(Ende2, 11)).Address

Worksheets("Auftrag").Range(Bereich1).ClearContents
Worksheets("Papiereinsatz").Range(Bereich2).ClearContents

'Application.ScreenUpdating = True

End Sub
Modul 4
nach oben
Option Explicit

Sub FilterAnalyse()
Dim SortenNr(1001), Beenden As Boolean
Dim I As Long
Dim X As Integer
Dim Ende1, Ende2, Ende3, Ende6 As Long
Dim A, B, C, D, E, F, SFqm, SFTonnen, Position As String
Dim Diff As Integer
Dim Summe(8) As String

Call Abbruch(Beenden)
If Beenden = True Then Exit Sub

Ende1 = Worksheets("Wellenkaliber").Range("Laenge1").Value
Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Ende6 = Worksheets("Wellenkaliber").Range("Laenge6").Value

If Ende1 = 4 Then
MsgBox ("Diese Liste enthält keine Daten")
Exit Sub
End If

'If Application.ActiveSheet.Index <> 1 Then
'MsgBox ("Bitte zuerst das Blatt" & Chr(13) _
'& """Auftrag""" & Chr(13) _
'& "aktivieren")
'Exit Sub
'End If

Application.ScreenUpdating = False

If Worksheets("Papiereinsatz").AutoFilterMode = True Then
    Worksheets("Papiereinsatz").AutoFilterMode = False
    Worksheets("Papiereinsatz").Rows("9:9").AutoFilter
        With Worksheets("Papiereinsatz").CommandButton1
        .Caption = "P994 Filter"
    End With
End If


Worksheets("Auftrag").Activate
'Call Modul3.LetzteZeile(Ende)
Position = ActiveCell.Address



For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 4).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 7).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 10).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 13).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 16).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 27).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 30).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 33).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 36).Value) = True
End If
Next I

For I = 5 To Ende1
If Rows(I).Hidden = False Then
SortenNr(Cells(I, 39).Value) = True
End If
Next I


Worksheets("Papiereinsatz").Activate
'Application.ScreenUpdating = True
Range("Sortenanzahl").ClearContents
Range("H4:K4").ClearContents
Range("D4:G4").ClearContents
Range("I3").ClearContents
Range("D7:K7").ClearContents
Range(Cells(10, 1), Cells(Ende2 + 10, 11)).ClearContents

X = 10
For I = 1 To 1001
If SortenNr(I) = True Then
Worksheets("Papiereinsatz").Cells(X, 1).Value = I
X = X + 1
End If
Next

X = X - 1

'For I = 10 To X
'Worksheets("Papiereinsatz").Cells(I, 2).Value = _
'Application.WorksheetFunction. _
'VLookup(Cells(I, 1).Value, Worksheets("Papierpreise"). _
'Range("A4:D93"), 2, False)
'
'Worksheets("Papiereinsatz").Cells(I, 3).Value = _
'Application.WorksheetFunction. _
'VLookup(Cells(I, 1).Value, Worksheets("Papierpreise"). _
'Range("A4:D93"), 3, False)
'
'Next I

Worksheets("Papiereinsatz"). _
Range("B10").FormulaLocal = "=SVERWEIS($A10;'Papierpreise'!$A$4:$D$" & Ende6 & ";2;Falsch)"
Worksheets("Papiereinsatz").Range("B10").Select
'Selection.AutoFill 'Destination:=Range("B2:B45") 'Destination:=Range(Cells(10, 2), Cells(2, X))
Selection.AutoFill Destination:=Range(Cells(10, 2), Cells(X, 2))

Worksheets("Papiereinsatz"). _
Range("C10").FormulaLocal = "=SVERWEIS($A10;'Papierpreise'!$A$4:$D$" & Ende6 & ";3;Falsch)"
Worksheets("Papiereinsatz").Range("C10").Select
Selection.AutoFill Destination:=Range(Cells(10, 3), Cells(X, 3))

Range(Cells(10, 2), Cells(X, 3)).Copy
Range(Cells(10, 2), Cells(X, 3)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Range("E9").Select

'------------------------------------------------------
'Analyse Teil 2
'P912

Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Ende3 = Worksheets("Wellenkaliber").Range("Laenge3").Value

'Application.ScreenUpdating = False

'A = "=(SUMMENPRODUKT((Auftrag!$D$5:$D$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
'B = "+SUMMENPRODUKT((Auftrag!$J$5:$J$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
'C = "+SUMMENPRODUKT((Auftrag!$P$5:$P$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "))"
'D = "+SUMMENPRODUKT((Auftrag!$G$5:$G$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AW$5:$AW$" & Ende3 & ")"
'E = "+SUMMENPRODUKT((Auftrag!$M$5:$M$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AX$5:$AX$" & Ende3 & ")"

A = "=(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""D""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
B = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""J""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
C = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""P""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
D = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""G""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AW$5:$AW$" & Ende3 &
    ")))"
E = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""M""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AX$5:$AX$" & Ende3 &
    ")))"

SFqm = A & B & C & D & E
Range("D10").FormulaLocal = SFqm


Range("E10").FormulaLocal = "=D10/$D$9*$E$9"

Range("F10").FormulaLocal = "=D10*C10/1000000"

Range("G10").FormulaLocal = "=F10/$D$9*$E$9"

Range("E9").Select
Worksheets("Papiereinsatz").Range("D10:G10").Select
Selection.AutoFill Destination:=Range(Cells(10, 4), Cells(Ende2, 7))

Worksheets("Papiereinsatz").Range(Cells(10, 4), Cells(Ende2, 4)).Copy
Range(Cells(10, 4), Cells(Ende2, 4)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Worksheets("Papiereinsatz").Range(Cells(10, 6), Cells(Ende2, 6)).Copy
Range(Cells(10, 6), Cells(Ende2, 6)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Range("D4").Select

A = "=""P912 = ""&ZÄHLENWENN(D10:D" & Ende2 & ";"">0"")&"" Sorten"""
Range("D4").FormulaLocal = A

'----------------------------------------------------------
'P994

'A = "=(SUMMENPRODUKT((Auftrag!$AA$5:$AA$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
'B = "+SUMMENPRODUKT((Auftrag!$AG$5:$AG$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & ")"
'C = "+SUMMENPRODUKT((Auftrag!$AM$5:$AM$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "))"
'D = "+SUMMENPRODUKT((Auftrag!$AD$5:$AD$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AW$5:$AW$" & Ende3 & ")"
'E = "+SUMMENPRODUKT((Auftrag!$AJ$5:$AJ$" & Ende3 & "=$A10)*Auftrag!$C$5:$C$" & Ende3 & "*Auftrag!$AX$5:$AX$" & Ende3 & ")"

A = "=(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""AA""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
B = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""AG""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
C = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""AM""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")))"
D = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""AD""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AW$5:$AW$" & Ende3
    & ")))"
E = "+(SUMMENPRODUKT((TEILERGEBNIS(6;INDIREKT(""Auftrag!""&""AJ""&ZEILE($5:$" & Ende3 & ")))=$A10)*(Auftrag!$C$5:$C$" & Ende3 & ")*(Auftrag!$AX$5:$AX$" & Ende3
    & ")))"

SFqm = A & B & C & D & E
Range("H10").FormulaLocal = SFqm

Range("I10").FormulaLocal = "=H10/$D$9*$E$9"

Range("J10").FormulaLocal = "=H10*C10/1000000"

Range("K10").FormulaLocal = "=J10/$D$9*$E$9"

Worksheets("Papiereinsatz").Range("H10:K10").Select
Selection.AutoFill Destination:=Range(Cells(10, 8), Cells(Ende2, 11))

Worksheets("Papiereinsatz").Range(Cells(10, 8), Cells(Ende2, 8)).Copy
Range(Cells(10, 8), Cells(Ende2, 8)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

Worksheets("Papiereinsatz").Range(Cells(10, 10), Cells(Ende2, 10)).Copy
Range(Cells(10, 10), Cells(Ende2, 10)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False

A = "=""P994 = ""&ZÄHLENWENN(H10:H" & Ende2 & ";"">0"")&"" Sorten""&""   Diff = ""&TEXT(Auftrag!AV3; ""#.##0 €"")"
Range("H4").FormulaLocal = A

Range("I3").Value = "Sortierung:" & Chr(10) & "Sorten"

Summe(0) = "=SUMME(D10:D" & Ende2 & ")"
Summe(1) = "=SUMME(E10:E" & Ende2 & ")"
Summe(2) = "=SUMME(F10:F" & Ende2 & ")"
Summe(3) = "=SUMME(G10:G" & Ende2 & ")"

Summe(4) = "=SUMME(H10:H" & Ende2 & ")"
Summe(5) = "=SUMME(I10:I" & Ende2 & ")"
Summe(6) = "=SUMME(J10:J" & Ende2 & ")"
Summe(7) = "=SUMME(K10:K" & Ende2 & ")"

Range("D7").FormulaLocal = Summe(0)
Range("E7").FormulaLocal = Summe(1)
Range("F7").FormulaLocal = Summe(2)
Range("G7").FormulaLocal = Summe(3)

Range("H7").FormulaLocal = Summe(4)
Range("I7").FormulaLocal = Summe(5)
Range("J7").FormulaLocal = Summe(6)
Range("K7").FormulaLocal = Summe(7)

Summe(8) = "=Anzahl2(A10:A" & Ende2 & ")"
Range("Sortenanzahl").FormulaLocal = Summe(8)

Range("E9").Select

Range(Position).Activate
Application.ScreenUpdating = True


MsgBox ("Berechnung ist fertig")

End Sub
Modul 5
nach oben
Sub Nullmenge()
' Autofilter ein und Beschriftung des CommandButton ändern
Dim Beenden As Boolean

Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Worksheets("Papiereinsatz").Activate
Application.ScreenUpdating = False

If Worksheets("Papiereinsatz").AutoFilterMode = True Then
    Rows("9:9").AutoFilter Field:=8, Criteria1:="<>0", Operator:=xlAnd
End If

If Not Worksheets("Papiereinsatz").AutoFilterMode = True Then
    Rows("9:9").AutoFilter
    Rows("9:9").AutoFilter Field:=8, Criteria1:="<>0", Operator:=xlAnd
End If

With Worksheets("Papiereinsatz").CommandButton1
.Caption = "P994 Filter aus"
End With

Application.ScreenUpdating = True

End Sub

Sub NullAus()
' Autofilter aus und Beschriftung des CommandButton ändern
Dim Beenden As Boolean

Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Worksheets("Papiereinsatz").Activate
Application.ScreenUpdating = False

    On Error Resume Next
    Selection.AutoFilter Field:=8

With Worksheets("Papiereinsatz").CommandButton1
.Caption = "P994 Filter"
End With

Application.ScreenUpdating = True
End Sub

Sub Gewicht_sortieren()
Dim Ende2 As Long
Dim Bereich As String
Dim Beenden As Boolean

Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Worksheets("Papiereinsatz").Activate

Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Bereich = "10:" & Ende2
    Rows(Bereich).Sort Key1:=Range("J10"), Order1:=xlDescending, Header:=xlGuess _
        , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("I3").Value = "Sortierung:" & Chr(10) & "Gewicht"
End Sub

Sub Sorten_sortieren()
Dim Ende2 As Long
Dim Bereich As String
Dim Beenden As Boolean

Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Worksheets("Papiereinsatz").Activate

Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Bereich = "10:" & Ende2
    Rows(Bereich).Sort Key1:=Range("A10"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("I3").Value = "Sortierung:" & Chr(10) & "Sorten"
End Sub

Sub qm_sortieren()
Dim Ende2 As Long
Dim Bereich As String
Dim Beenden As Boolean

Call Abbruch(Beenden) 'Modul7
If Beenden = True Then Exit Sub

Worksheets("Papiereinsatz").Activate

Ende2 = Worksheets("Wellenkaliber").Range("Laenge2").Value
Bereich = "10:" & Ende2
    Rows(Bereich).Sort Key1:=Range("H10"), Order1:=xlDescending, Header:=xlGuess _
        , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("I3").Value = "Sortierung:" & Chr(10) & "qm"
End Sub
Modul 6
nach oben
Option Explicit

Option Explicit
Sub Abbruch(Beenden As Boolean)
' Prüfung, ob die Tabellenstruktur verändert wurde
' und Übergabe von "WAHR" oder "FALSCH" an
' die aufrufende Prozedur
Dim Pruefung1, Pruefung2 As String
Dim Antwort

Pruefung1 = Left(Worksheets("Papiereinsatz").Range("K9").Formula, 10)
Pruefung2 = Worksheets("Auftrag").Range("AX4").Value

If Pruefung1 <> "=E9/1" Or Pruefung2 <> "WE2" Then
    Beenden = True

    Antwort = MsgBox( _
    "Die Tabellenstruktur auf dem Worksheet ""Auftrag""" & Chr(13) _
    & "oder ""Papiereinsatz"" wurde verändert. Darum können" & Chr(13) _
    & "die Dateiinternen Programme nicht mehr richtig arbeiten" & Chr(13) _
    & "und werden deshalb deaktiviert." & Chr(13) & Chr(13) _
    & "Lösung:" & Chr(13) _
    & "Entweder die alte Struktur wieder herstellen oder" & Chr(13) _
    & "die Programme überarbeiten." & Chr(13) _
    & "(HS)", 16, "Prüfung der Tabellenstruktur")
        Else
        Beenden = False
End If
End Sub
CommandButtons
nach oben
Option Explicit

Option Explicit
Private Sub CommandButton1_Click()
' Autofilter aktivieren / deaktivieren in Abhängigkeit
' der momentanen Beschriftung des CommandButtons auf Tabelle(2)
With CommandButton1
    If .Caption = "P994 Filter" Then
        Nullmenge  'in Modul6
        Else
        NullAus    'in Modul6
    End If
End With
End Sub

Private Sub Worksheet_Activate()
' Benutzermenüpunkt aktivieren
Dim cbSpecialMenu As CommandBarPopup
Dim UMenu As CommandBarPopup
  On Error Resume Next
    Set cbSpecialMenu = _
    Application.CommandBars("Worksheet Menu " & _
    "Bar").Controls("Papiermenü")
    Set UMenu = _
    cbSpecialMenu.Controls("Papiereinsatz")
  UMenu.Enabled = True
End Sub

Private Sub Worksheet_Deactivate()
' Benutzermenüpunkt deaktivieren
Dim cbSpecialMenu As CommandBarPopup
Dim UMenu As CommandBarPopup
  On Error Resume Next
    Set cbSpecialMenu = _
    Application.CommandBars("Worksheet Menu " & _
    "Bar").Controls("Papiermenü")
    Set UMenu = _
    cbSpecialMenu.Controls("Papiereinsatz")
  UMenu.Enabled = False
End Sub
Menue
nach oben
Private Sub Workbook_Open()

Dim cbMenu As CommandBar
Dim cbSpecialMenu As CommandBarPopup
Dim cbCommand As CommandBarControl
Dim UMenu As CommandBarPopup
Dim UcbCommand As CommandBarControl

On Error Resume Next
Application.CommandBars("Worksheet Menu " & _
"Bar").Controls("Papiermenü").Delete

  Set cbSpecialMenu = _
  Application.CommandBars("Worksheet Menu Bar") _
  .Controls.Add(Type:=msoControlPopup)
  cbSpecialMenu.Caption = "&Papiermenü"


  Set cbCommand = _
  cbSpecialMenu.Controls.Add(Type:=msoControlButton)
  cbCommand.Caption = "&Daten holen"
  cbCommand.OnAction = "DatenHolen"

  Set cbCommand = _
  cbSpecialMenu.Controls.Add(Type:=msoControlButton)
  cbCommand.Caption = "&Analyse"
  cbCommand.OnAction = "Analyse"

  Set cbCommand = _
  cbSpecialMenu.Controls.Add(Type:=msoControlButton)
  cbCommand.Caption = "&Filter-Analyse"
  cbCommand.OnAction = "FilterAnalyse"
  cbCommand.TooltipText = "Achtung: dauert wegen umfangreicher Berechnungen länger"
  cbCommand.BeginGroup = True

  Set cbCommand = _
  cbSpecialMenu.Controls.Add(Type:=msoControlButton)
  cbCommand.Caption = "&Löschen"
  cbCommand.OnAction = "alles_löschen"
  cbCommand.BeginGroup = True

  Set UMenu = _
  cbSpecialMenu.Controls.Add(Type:=msoControlPopup)
  UMenu.Caption = "&Papiereinsatz"
  UMenu.BeginGroup = True
  If ActiveSheet.Name <> "Papiereinsatz" Then
    UMenu.Enabled = False
  End If

  Set UcbCommand = _
  UMenu.Controls.Add(Type:=msoControlButton)
  UcbCommand.Caption = "&Nullmengen ausfiltern"
  UcbCommand.OnAction = "Nullmenge"
  'UcbCommand.BeginGroup = True

  Set UcbCommand = _
  UMenu.Controls.Add(Type:=msoControlButton)
  UcbCommand.Caption = "Nullmengen &Filter aus"
  UcbCommand.OnAction = "NullAus"

  Set UcbCommand = _
  UMenu.Controls.Add(Type:=msoControlButton)
  UcbCommand.Caption = "&Gewicht sortieren"
  UcbCommand.OnAction = "Gewicht_sortieren"
  UcbCommand.BeginGroup = True

  Set UcbCommand = _
  UMenu.Controls.Add(Type:=msoControlButton)
  UcbCommand.Caption = "&qm sortieren"
  UcbCommand.OnAction = "qm_sortieren"

  Set UcbCommand = _
  UMenu.Controls.Add(Type:=msoControlButton)
  UcbCommand.Caption = "&Sorten sortieren"
  UcbCommand.OnAction = "Sorten_sortieren"


  Application.Caption = "Excel-Tuning by HS"
'  Windows(1).Caption = ActiveWorkbook.Name
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim cbSpecialMenu As CommandBarControl

  On Error Resume Next
  Set cbSpecialMenu = _
  Application.CommandBars("Worksheet Menu " & _
  "Bar").Controls("Papiermenü")
  cbSpecialMenu.Delete

  Application.Caption = ""
'  Windows(1).Caption = ActiveWorkbook.Name
End Sub

Private Sub Workbook_Deactivate()
  On Error Resume Next
  Application.CommandBars("Worksheet Menu " & _
  "Bar").Controls("Papiermenü").Visible = False

  Application.Caption = ""
'  Windows(1).Caption = ActiveWorkbook.Name
End Sub

Private Sub Workbook_Activate()
  On Error Resume Next
  Application.CommandBars("Worksheet Menu " & _
  "Bar").Controls("Papiermenü").Visible = True

  Application.Caption = "Excel-Tuning by HS"
'  Windows(1).Caption = ActiveWorkbook.Name
End Sub

'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'    If Application.ActiveSheet.Name <> "Tabelle1" Then
'    Exit Sub
'    End If
'
'    Range("E3").Select
'    A = Application.WorksheetFunction.CountA(Range("A:A"))
'    If A <= 2 Then
'    Range("A3").Select
'    Exit Sub
'    End If
'    Range(Cells(3, 5), Cells(A, 5)).Select
'    Selection.FillDown
'    Range("A3").Select
'
Die Excel Wühlkiste
Valid HTML 4.01 Strict
letzte Aktualisierung: 27.04.2009
Autor: Hubert Scheidgen / 27.04.2009
W3C CSS-Validierungsservice