Die Excel Wühlkiste

Abwertung

nach HGB- und Konzernrichtlinien
Errechnen der Bestandskorrektur für die Bilanz. Im vorliegenden Projekt geht es um Ersatzteile.
  Hier stellen sich insbesondere Fragen: Wie alt ist ein Teil, oder wann wurde es angeschafft? Wie hoch ist die augenblickliche Bestandsmenge? Welchen Gesamtwert haben alle Teile eines Artikels?
  Das Anschaffungsdatum bestimmt die Altersgruppe und damit die Höhe der Abwertung nach dem Prinzip "first in - last out".
  Gemäß Konzernrichlinie wird ein Teil, wenn es bis ein Jahr alt ist, gar nicht abgewertet. Teile die 1-2 Jahre alt sind, zu 50% und Teile, die älter als 2 Jahre sind, zu 100% abgewertet. Teile von 0,- bis 100,- Euro Einzelwert (gleitender Durchschnittswert) werden ebenfalls zu 100% abgewertet, egal, wie alt sie sind.
  Nach HGB werden die Teile alle komplett zu 20% abgewertet.

Grundlage bilden drei Auswertungen aus SAP:
- die Bestandswertliste
- die Einkaufsliste 0-1 Jahr
- die Einkaufsliste 1-2 Jahre

Die Auswertungen liegen in nicht direkt verwendbaren Formaten vor. Sie werden für Excel im vorliegenden Programm aufbereitet, gespeichert und anschließend werden die Berechnungen für jedes einzelne Teil ausgeführt. Die Daten für jedes einzelne Teil und die Gesamtwerte werden in einer Abschlussdatei gespeichert und sind alle auf Plausibilität prüfbar. Das ist wichtig für Finanz- und Wirtschaftsprüfungen.

 

 
Jeder, der sich schon einmal mit genau dieser Thematik befassen musste, weiß, dass schon mal gerne 2 Tage dafür verbraucht werden. Mit dem vorliegenden Programm dauert das gerade mal 15 Minuten. Und das auch nur deshalb, weil das Ziehen der SAP-Auswertungen ja auch Zeit braucht. Der eigentliche Rechenvorgang benötigt pro. 1 Mio. Euro Ersatzteilbestand ca. 12 Sekunden. In dieser Zeit sind bereits alle nötigen Serverzugriffe enthalten.

Zu diesem Programm gibt es eine Readme-Datei.
Alle Dateien des Projekts gibts hier als ZIP-Archiv (189 KB): Download
Das Archiv enthält auch die Readme-Datei. Mit den enthaltenen Dateien und Daten ist das Projekt, um einen ersten Eindruck zu gewinnen, komplett lauffähig. Für ein "Going Life" in einem anderen Unternehmen oder in einem anderen SAP-Umfeld werden aber ganz sicher Anpassungen nötig sein.

  Modul 1     Modul 2     Modul 3     CommandButtons     Menue  


Screenshot 1
Screenshot 1
Screenshot 2
Screenshot 2

Hinzugefügt am 23.09.22209: Inzwischen gibt es schon wieder eine neue Version, die das notwendige Mapping von alten Materialnummern zu neuen beinhaltet.
Danke für´s Testen an Klaus Kuhnen und Michael Stein.
Modul 1
Option Explicit

Private Monat As String
Private Jahr As String
Private Datum As String
Private Pfad As String
Private i As Long
Private ServerPfad As String
Private sFile As String, sPath As String

Sub Abwertung_Konzern()

Dim Datei0 As String 'Bestandsliste aus SAP (kein .xls file)
Dim Datei1 As String 'Bestandsliste aus SAP (als .xls file)
Dim Datei2 As String 'Abwertungstabelle als .xls file
Dim Datei3 As String 'Einkaufstabelle 0-1 Jahr  als .xls file aus SAP
Dim Datei4 As String 'Einkaufstabelle 1-2 Jahre als .xls file aus SAP
Dim Blattname As String
Dim Spaltenkopf As String
Dim MN 'Materialnummer
Dim AnzahlZeilenDatei1 As Long
Dim AnzahlZeilenDatei2 As Long
Dim AZD3 As Long 'AnzahlZeilenDatei3
Dim AZD4 As Long 'AnzahlZeilenDatei4


'Einlesen Monat und Jahr der Abwertung aus der Startseite
'und Variablenzuweisung
With Workbooks("1Abwertung-Ersatzteile-Programm.xls").Worksheets(1)
    Monat = .Range("C4").Value
    If Len(Monat) = 1 Then Monat = "0" & Monat

    Jahr = .Range("C5").Value
    If Left(Jahr, 2) <> "20" Then Exit Sub 'Spassvogelsperre
End With

Datum = Monat & "." & Jahr



'**************************************************************
'--------------------------------------------------------------
'Hier den Pfad für das unterste Verzeichnis und das
'Serververzeichnis anpassen
'zum Beispiel in Brühl: Inventur 2008\12-08
'das sieht dann so aus:
'Pfad = "Inventur " & Jahr & "\" & Monat & "-" & Right(Jahr, 2)
'ServerPfad = "\\Gb-lon2-x001\irgendwas        \Einkauf\Excel\Ersatzteile\" & Pfad
ServerPfad = Worksheets(1).Range("B11").Value

If ServerPfad = "" Then
    MsgBox ("Bitte erst den korrekten Pfad holen")
    Exit Sub
End If
'--------------------------------------------------------------
'**************************************************************



Datei0 = Worksheets(1).Range("B12").Value 'SAP Buchbestand (*.dba)
'Datei1 = "Buchbestand.xls"                'Datei0 als *.xls File
Datei1 = Left(Datei0, Len(Datei0) - 4) & ".xls"
Datei2 = Worksheets(1).Range("B13").Value 'Abwertungsdatei (*.xls)
Datei3 = Worksheets(1).Range("B14").Value 'Teile gekauft bis 1 Jahr (*.xls)
Datei4 = Worksheets(1).Range("B15").Value 'Teile gekauft 1-2 Jahre (*.xls)
Blattname = "SAP Bestände Ende " & Datum
Spaltenkopf = "Bestand " & Datum & " " & "Stück"

If Datei0 = "" Or _
    Datei2 = "" Or _
    Datei3 = "" Or _
    Datei4 = "" Then
    MsgBox ("Bitte erst Alle Dateinamen holen" & Chr(13) _
    & "Menü: ""Pfad holen"" ausführen")
    Exit Sub
End If


Application.ScreenUpdating = False

'ChDir ServerPfad



'prüfen, ob die AbwertungsDatei geöffnet ist.
'Wenn ja, ist sie zu aktivieren, wenn nein zu öffnen.
'Existiert die Datei nicht im Verzeichnis dieser Arbeitsmappe,
'wird eine entsprechende Meldung auszugeben.

sFile = Datei2
sPath = ServerPfad & sFile
If WkbExists(sFile) = False Then
    If dir(sPath) = "" Then
        MsgBox "Datei " & sFile & " wurde nicht gefunden!"
        Exit Sub
    Else
        Workbooks.Open FileName:=sFile, UpdateLinks:=True
    End If
End If



'prüfen, ob die Bestandsdatei aus SAP geöffnet ist.
'Wenn ja, ist sie zu schließen ohne zu speichern,
'und anschließen mit genau definierten Parametern zu öffnen,
'wenn nein, ist sie nur mit genau definierten Parametern zu öffnen.
'Existiert die Datei nicht im Verzeichnis dieser Arbeitsmappe,
'wird eine entsprechende Meldung auszugeben.

sFile = Datei0
sPath = ServerPfad & sFile

If WkbExists(sFile) = True Then
    Workbooks(sFile).Close SaveChanges:=False
End If

If WkbExists(sFile) = False Then


    If dir(sPath) = "" Then
        MsgBox "Datei " & sFile & " wurde nicht gefunden!"
        Exit Sub
    Else
        Workbooks.OpenText FileName:=sFile _
            , Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
            :=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _
            False, Comma:=False, Space:=False, Other:=False ', TrailingMinusNumbers:=True
    End If
End If



'Workbooks.OpenText Filename:=Datei0 _
'    , Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
'    :=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _
'    False, Comma:=False, Space:=False, Other:=False, TrailingMinusNumbers:=True


'    Workbooks.OpenText Filename:=Datei0 _
'        , Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
'        :=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _
'        False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array _
'        (1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True

'Application.DisplayAlerts = False
'Application.Workbooks(Datei0).SaveAs FileName:=Datei1, FileFormat:=xlNormal
'Application.DisplayAlerts = True




'prüfen, ob die Excel-Bestandsdatei geöffnet ist.
'Wenn ja, ist sie zu schließen ohne zu speichern,
'und anschließend wird die SAP-Bestandsdatei unter
'dem Namen der Excel-Bestandsdatei als *.xls Datei
'gespeichert

sFile = Datei1
sPath = ServerPfad & sFile

If WkbExists(sFile) = True Then
    Workbooks(sFile).Close SaveChanges:=False
Else
    Application.DisplayAlerts = False
    Application.Workbooks(Datei0).SaveAs FileName:=Datei1, FileFormat:=xlNormal
    Application.DisplayAlerts = True
End If


'Application.Workbooks(Datei1).Activate

With Application.Workbooks(Datei1).Worksheets(1)

    .Range("A1:A8").EntireRow.Delete
    .Range("A1:H1").EntireColumn.Delete
    .Range("A1").EntireRow.ClearContents
    .Range("A1").Value = "Material"
    .Range("B1").Value = "Materialkurztext"
    .Range("C1").Value = "GesBestand"
    .Range("D1").Value = "BME"
    .Range("E1").Value = "Gesamtwert"
    .Range("F1").Value = "Währg"

    With .Range("A1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Font.Bold = True
    End With

    .Range("A:F").Columns.AutoFit



    'Programmabbruch, wenn die SAP-Bestandsdatei leer ist
    If .Range("A1").End(xlDown) = 65536 Then
        MsgBox ("keine SAP-Bestände vorhanden" & Chr(13) _
                    & "Programmabbruch!")
        Exit Sub
    End If

    Do Until .Range("A1").End(xlDown).Offset(2, 0).Value = ""

        If .Range("A1").End(xlDown).Offset(1, 0).Value = "" Then
            .Range("A1").End(xlDown).Offset(1, 0).EntireRow.Delete
        End If
    Loop

    AnzahlZeilenDatei1 = .Range("A1").End(xlDown).Row

    For i = 2 To AnzahlZeilenDatei1
        .Range("A" & i).Value = .Range("A" & i).Value * 1
        .Range("C" & i).Value = .Range("C" & i).Value * 1
        .Range("E" & i).Value = .Range("E" & i).Value * 1
    Next i

End With


Application.Calculation = xlManual

Application.Workbooks(Datei1).Save


With Application.Workbooks(Datei2).Worksheets(1)
    AnzahlZeilenDatei2 = .Range("A1").End(xlDown).Row

    If AnzahlZeilenDatei2 = 65536 Then
        AnzahlZeilenDatei2 = 2
        .Range("A2") = 300000
        .Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert Shift:=xlDown
    End If



    If AnzahlZeilenDatei2 < AnzahlZeilenDatei1 Then
        For i = AnzahlZeilenDatei2 To AnzahlZeilenDatei1 - 1
            .Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert Shift:=xlDown
        Next i
    End If

    If AnzahlZeilenDatei2 > AnzahlZeilenDatei1 Then
        For i = AnzahlZeilenDatei1 To AnzahlZeilenDatei2 - 1
            .Range("A2").EntireRow.Delete
        Next i
    End If
End With

With Application.Workbooks(Datei1).Worksheets(1)
    .Range(.Cells(2, 1), .Cells(AnzahlZeilenDatei1, 4)).Copy
    Application.Workbooks(Datei2).Worksheets(1).Range("A2").PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False

    .Range(.Cells(2, 5), .Cells(AnzahlZeilenDatei1, 5)).Copy
    Application.Workbooks(Datei2).Worksheets(1).Range("G2").PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False

    .Range(.Cells(2, 6), .Cells(AnzahlZeilenDatei1, 6)).Copy
    Application.Workbooks(Datei2).Worksheets(1).Range("I2").PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
End With

Application.Workbooks(Datei2).Save
Application.Workbooks(Datei1).Close
Application.Workbooks(Datei2).Activate


Einkaufstabellen_aufbereiten (Datei3)
    If dir(sPath) = "" Then
        Exit Sub
    End If
Einkaufstabellen_aufbereiten (Datei4)
    If dir(sPath) = "" Then
        Exit Sub
    End If


With Application.Workbooks(Datei2).Worksheets(1)

    '--------------------------------------------------------------------------------
    ' Mengen aus den Einkaufstabellen holen und danach die Zellen berechnen:
    Workbooks.Open FileName:=Datei3
    Workbooks.Open FileName:=Datei4

    'Zeilenanzahl der Einkaufstabellen holen
    AZD3 = Application.Workbooks(Datei3).Worksheets(1).Range("A1").End(xlDown).Row
    AZD4 = Application.Workbooks(Datei4).Worksheets(1).Range("A1").End(xlDown).Row

    For i = 2 To AnzahlZeilenDatei1 'Zeilenzahl der Abwertungstabelle
        'Do Until ActiveCell.Value = ""
           MN = .Range("A" & i).Value  'Materialnummer der Zeile einlesen

           'Einkaufsmenge 0-1 Jahr holen in Spalte J
           .Range("J" & i).Value = _
           Evaluate("=SumProduct(('[" & Datei3 & "]Tabelle1'!H2:H" & AZD3 & "=" & MN & ")*" & _
           "('[" & Datei3 & "]Tabelle1'!P2:P" & AZD3 & "))")

           'Einkaufsmenge 1-2 Jahre holen in Spalte K
               .Range("K" & i).Value = _
           Evaluate("=SumProduct(('[" & Datei4 & "]Tabelle1'!H2:H" & AZD4 & "=" & MN & ")*" & _
           "('[" & Datei4 & "]Tabelle1'!P2:P" & AZD4 & "))")
        'Loop


        'Einzelpreise berechnen in Spalte F
        If .Range("G" & i).Value = 0 Then
            .Range("F" & i).Value = 0
        Else
            .Range("F" & i).Value = .Range("G" & i).Value / .Range("C" & i).Value
        End If


        'Gesamtwert der Teile grösser 100 Euro berechnen in Spalte H
        If .Range("F" & i).Value > 100 Then
            .Range("H" & i).Value = .Range("G" & i).Value
        Else
            .Range("H" & i).Value = 0
        End If


        'Abwertung Stück 0% 0-1 Jahr in Spalte L
        If .Range("C" & i).Value > .Range("J" & i).Value Then
            .Range("L" & i).Value = .Range("J" & i).Value
        Else
            .Range("L" & i).Value = .Range("C" & i).Value
        End If


        'Abwertung Stück 50% 1-2 Jahre in Spalte M
        If .Range("J" & i).Value >= .Range("C" & i).Value Then
            .Range("M" & i).Value = 0
        ElseIf .Range("J" & i).Value + .Range("K" & i).Value <= .Range("C" & i).Value Then
            .Range("M" & i).Value = .Range("K" & i).Value
        Else
            .Range("M" & i).Value = .Range("C" & i).Value - .Range("J" & i).Value
        End If


        'Abwertung Stück 100% mehr als 2 Jahre in Spalte N
        .Range("N" & i).Value = .Range("C" & i).Value - .Range("L" & i).Value - .Range("M" & i).Value


        'Abwertung Wert in Spalte O bis Q
        If .Range("C" & i).Value = 0 Then
            .Range("O" & i).Value = 0
            .Range("P" & i).Value = 0
            .Range("Q" & i).Value = 0
        Else
            .Range("O" & i).Value = .Range("L" & i).Value * (.Range("H" & i).Value / .Range("C" & i).Value)
            .Range("P" & i).Value = .Range("M" & i).Value * (.Range("H" & i).Value / .Range("C" & i).Value)
            .Range("Q" & i).Value = .Range("N" & i).Value * (.Range("H" & i).Value / .Range("C" & i).Value)
        End If

        'Abwertung Wert aller Teile <= 100 Euro in Spalte R
        If .Range("F" & i).Value <= 100 Then
            .Range("R" & i).Value = .Range("G" & i).Value
        Else
            .Range("R" & i).Value = 0
        End If

    Next i
    Application.Workbooks(Datei3).Close
    Application.Workbooks(Datei4).Close


    '--------------------------------------------------------------------------------

 'Beschriftungen anpassen
    .Range("A" & AnzahlZeilenDatei1 + 1).Select
    .Range("C1").Value = Spaltenkopf
    .Range("K" & AnzahlZeilenDatei1 + 19).Value = "Summe Wertberichtigung " & Datum & " (Konzern)"
    .Range("K" & AnzahlZeilenDatei1 + 20).Value = "Summe Wertberichtigung " & Datum & " 20% (HGB)"
    Worksheets(1).Name = Blattname

    Application.Calculation = xlAutomatic
    Application.Workbooks(Datei2).Save

End With

Application.ScreenUpdating = True

MsgBox ("Berechnung der Abwertung" & Chr(13) _
& "ohne Programmfehler fertiggestellt." & Chr(13) _
& "Bitte die Stichproben nicht vergessen," & Chr(13) _
& "denn für die Richtigkeit der Abwertungs-" & Chr(13) _
& "summen sind sie selber verantwortlich." & Chr(13) _
& "Dafür übernehme ich keine Garantie.")

End Sub

Private Function Einkaufstabellen_aufbereiten(EKT As String)
'bestimmte SAP Zeilen und -Spalten löschen und
'Texte in Werte umwandeln
'EKT = die jeweilige Einkaufstabelle

Dim AnzahlZeilenEKT As Long
'ChDir ServerPfad

sFile = EKT
sPath = ServerPfad & sFile
If WkbExists(sFile) = False Then
    If dir(sPath) = "" Then
        MsgBox "Datei " & sFile & " wurde nicht gefunden!"
        Exit Function
    Else
        Workbooks.Open FileName:=EKT
    End If
End If


With Application.Workbooks(EKT).Worksheets(1)
    AnzahlZeilenEKT = .Range("A1").End(xlDown).Row
    For i = 2 To AnzahlZeilenEKT
    .Range("H" & i).Value = .Range("H" & i).Value * 1

    .Range("P" & i).Value = .Range("P" & i).Value * 1

    Next i
    .Range("H:H").NumberFormat = "0"
    .Range("P:P").NumberFormat = "0.000"
End With
Application.Workbooks(EKT).Save
Application.Workbooks(EKT).Close
End Function

Private Function WkbExists(sFile As String) As Boolean
'prüfen, ob die entsprechenden Tabellen bereits geöffnet sind, oder nicht

Dim wkb As Object

   On Error Resume Next
   Set wkb = Workbooks(sFile)
   If Not wkb Is Nothing Then
      WkbExists = True
      wkb.Activate
   End If
   On Error GoTo 0
End Function
Modul 2
Option Explicit

Function PfadHolen(i) As String

    Select Case i

    Case 11, 12
    PfadHolen = Application.GetOpenFilename("SAP Dateien (*.dba), *.dba", , _
    "Klicken Sie auf die ""SAP Buchestand"" Datei und dann auf Öffnen.")
'    ChDrive Left(Datei(11), InStr(Datei(11), Dir(Datei(11))) - 1)
    Case 13
    PfadHolen = Application.GetOpenFilename("Excel Dateien (*.xls), *.xls", , _
    "Aussuchen der ""Abwertungs"" Datei. Klicken Sie anschließend auf öffnen")
    Case 14
    PfadHolen = Application.GetOpenFilename("Excel Dateien (*.xls), *.xls", , _
    "Aussuchen der ""E-Teile Kauf bis 1 Jahr"" Datei. Klicken Sie anschließend auf öffnen")
    Case 15
    PfadHolen = Application.GetOpenFilename("Excel Dateien (*.xls), *.xls", , _
    "Aussuchen der ""E-Teile Kauf 1-2 Jahre"" Datei. Klicken Sie anschließend auf öffnen")
    End Select

End Function

Function schreiben(i As Integer, Dateiname As String)
Dim Text As String
Dim Antwort As Integer

Text = PfadHolen(i)

weiter:
If Text = "Falsch" Then
    Antwort = MsgBox("Keine Datei ausgewählt!" & Chr(13) _
    & "Diese Datei noch einmal wählen?", vbYesNo + vbDefaultButton1, "Falsche Auswahl!")
    If Antwort = vbYes Then
        Text = PfadHolen(i)
        GoTo weiter
    Else
        'Range("B" & i) = ""
        Exit Function
    End If
End If
If dir(Text) = "1Abwertung-Ersatzteile-Programm.xls" Then
    Antwort = MsgBox("Sie haben die Abwertungs-Programm-Datei ausgewählt!" & Chr(13) _
    & "Sie müssen die " & Dateiname & " auswählen." & Chr(13) _
    & "Noch einmal wählen?", vbYesNo + vbDefaultButton1, "Falsche Auswahl!")
    If Antwort = vbYes Then
    Text = PfadHolen(i)
    GoTo weiter
    Else
        'Range("B" & i) = ""
        Exit Function
    End If

End If


If i = 11 Then
    Range("B" & i) = Left(Text, InStr(Text, dir(Text)) - 1)
    Range("B" & i + 1) = dir(Text)
Else
    Range("B" & i) = dir(Text)
End If


End Function

Function Pfad()
schreiben 11, "Datei SAP Buchestand.dba"
End Function
Modul 3
Sub netzwerk_durchsuchen()
Dim Ordnerpfad
Dim dat
Set dat = Application.FileDialog(msoFileDialogFilePicker)
With dat
   .Title = "Netzwerk...."
   .InitialFileName = "d:\" 'oder was auch immer
              If .Show = -1 Then
                  For Each Ordnerpfad In .SelectedItems
                          MsgBox Ordnerpfad 'Zur weiteren verwendung
                  Next Ordnerpfad
             End If
    End With
End Sub
CommandButtons
Private Sub CommandButton1_Click()
' Verweis auf Microsoft Outlook Bibliothek setzen
Dim objOL As Object
Dim objMail As Object

Dim EMailan As String ' 2) oder As Range
Dim Betreff As String

EMailan = "hubert@scheidgen1.de"
Betreff = "Hilfeanfrage Ersatzteilabwertung"

Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItem(0)

With objMail
    .To = EMailan
    .Subject = Betreff
    .Body = "Hallo Kollege," & Chr(13) & Chr(13)
    '.Attachments.Add ActiveWorkbook.FullName
    .display ' Display für Indirektversand oder .Send für Direktversand
End With
Set objOL = Nothing
Set objMail = Nothing
End Sub

Private Sub CommandButton2_Click()
schreiben 11, "Datei SAP Buchestand.dba"
End Sub

Private Sub CommandButton3_Click()
schreiben 12, "Datei SAP Buchestand.dba"
End Sub

Private Sub CommandButton4_Click()
schreiben 13, "Datei, welche die Abwertungs-Daten" & Chr(13) & "enthalten soll,"
End Sub

Private Sub CommandButton5_Click()
schreiben 14, "Datei, welche die die Einkäufe" & Chr(13) & "bis 1 Jahr enthält,"
End Sub

Private Sub CommandButton6_Click()
schreiben 15, "Datei, welche die die Einkäufe" & Chr(13) & "1 bis 2 Jahre enthält,"
End Sub
Menue
Private Sub Workbook_Open()

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

On Error Resume Next
Application.CommandBars("Worksheet Menu " & _
"Bar").Controls("Abwertung E-Teile").Delete
'Application.CommandBars("Worksheet Menu " & _
'"Bar").Controls("Spezialmenü").Delete


  Set cbSpecialMenu = _
  Application.CommandBars("Worksheet Menu Bar") _
  .Controls.Add(Type:=msoControlPopup)
  cbSpecialMenu.Caption = "Ab&wertung E-Teile"
  cbSpecialMenu.TooltipText = "Spezialmenü für diese Arbeitsmappe"


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


  Set cbCommand = _
  cbSpecialMenu.Controls.Add(Type:=msoControlButton)
  cbCommand.Caption = "&Abwertung starten"
  cbCommand.OnAction = "Abwertung_Konzern"
  cbCommand.BeginGroup = True

  Application.Caption = "Excel-Tuning by HS"
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("Abwertung E-Teile")
  cbSpecialMenu.Delete

  Application.Caption = ""

  Set cbSpecialMenu = Nothing
  Set cbCommand = Nothing
  Set UMenu = Nothing
  Set UcbCommand = Nothing


End Sub

Private Sub Workbook_Deactivate()
  On Error Resume Next
  Application.CommandBars("Worksheet Menu " & _
  "Bar").Controls("Abwertung E-Teile").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("Abwertung E-Teile").Visible = True

  Application.Caption = "Excel-Tuning by HS"
End Sub
Die Excel Wühlkiste
Valid HTML 4.01 Strict
letzte Aktualisierung: 23.09.2009
Autor: Hubert Scheidgen / 04.02.2009
W3C CSS-Validierungsservice