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
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
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
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
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
