Option Explicit
Dim Marke As String
Public Monat As String
Dim DokPfad As String
Dim DokPreis As String
Dim DokName As String
Dim Jahr As Integer
Dim Fileext As String
Dim xAlerts As Boolean
Dim WorkB As Workbook
Dim WBP As Workbook
Dim WSP As Worksheet
Dim WorkS As Worksheet
Dim xSht As Variant
Dim ThisPos As Range
Dim ThisRow As Long
Dim DokNameYear As String
Dim ZeileMax As Long
Dim Model As String
Dim PosMod As Range
Dim ModZeile As Long
Dim i As Variant
Dim Pfad As String
Sub Monats_Abrechnung_intern_Reinach()
Set WorkB = ThisWorkbook
Abrechnungs_Monat_intern.Show
If Monat = "Dezember" And Format(Date, "mmmm") = "Januar" Then
Jahr = Year(Date) - 1
Else
Jahr = Year(Date)
End If
Fileext = ".xlsx"
Pfad = "X:\6_Administration\Verkauf\Verkauf intern\"
DokName = ("Monatsabrechnung intern Reinach " & Monat & " " & Jahr & Fileext)
DokPfad = (Pfad & Monat & "\" & DokName)
DokPreis = (Pfad & "Preisliste.xlsm")
Set WBP = Workbooks.Open(DokPreis)
DokNameYear = (Pfad & "Jahresabrechnung intern Reinach " & Jahr & Fileext)
Workbooks.Add.SaveAs Filename:=DokPfad
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each xSht In ThisWorkbook.Sheets
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = xSht.Name
WorkB.Worksheets("Finn Comfort").Range("A1:E1").Copy
ActiveSheet.Range("A1:E1").PasteSpecial (xlPasteFormats)
ActiveSheet.Range("D1:G1").PasteSpecial (xlPasteFormats)
ActiveSheet.Range("A1:E1").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("F1").Value = "EP"
ActiveSheet.Range("F2:F200").NumberFormat = "$ #,##0.00"
ActiveSheet.Range("G1").Value = "Summe"
ActiveSheet.Range("G2:G200").NumberFormat = "$ #,##0.00"
ActiveSheet.Range("A2:G200").FormatConditions.Add Type:=xlExpression, Formula1:="=UND((ISTLEER($F2)=WAHR);(ISTLEER($E2)=FALSCH))"
ActiveSheet.Range("A2:G200").FormatConditions(ActiveSheet.Range("A2:G200").FormatConditions.Count).SetFirstPriority
With ActiveSheet.Range("A2:G200").FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
ActiveSheet.Range("A2:G200").FormatConditions(1).StopIfTrue = False
Set ThisPos = WorkB.Worksheets(xSht.Name).Range("E:E").Find(What:=Monat, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not ThisPos Is Nothing Then
Do
ThisRow = ThisPos.Row
ActiveSheet.Range("A2").EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
ActiveSheet.Range("A2").Resize(1, 5).Value = WorkB.Worksheets(xSht.Name).Range("A" & ThisRow & ":E" & ThisRow).Value
WorkB.Worksheets(xSht.Name).Range("A" & ThisRow & ":E" & ThisRow).ClearContents
Set ThisPos = WorkB.Worksheets(xSht.Name).Range("E:E").FindNext(ThisPos)
WorkB.Worksheets(xSht.Name).Range("A" & ThisRow & ":G" & ThisRow).Delete
Loop While Not ThisPos Is Nothing
If xSht.Name = "Finn Comfort" Then
With WorkB.Worksheets(xSht.Name).Shapes("Schaltfläche 1")
.Top = .TopLeftCell.Offset(-1, 0).Top
End With
End If
Else
End If
Set WSP = WBP.Worksheets(xSht.Name)
ZeileMax = Workbooks(DokName).Worksheets(xSht.Name).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To ZeileMax
Model = ActiveSheet.Range("C" & i).Value
Set PosMod = WSP.Range("A:A").Find(What:=Model, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not PosMod Is Nothing Then
ModZeile = PosMod.Row
ActiveSheet.Range("F" & i).Value = WSP.Range("D" & ModZeile).Value
ActiveSheet.Range("G" & i).Formula = "=$A" & i & "*$F" & i
Else
End If
Next
ActiveSheet.Range("F" & (ZeileMax + 2)).Value = "Summe:"
ActiveSheet.Range("G" & (ZeileMax + 2)).Formula = "=SUM($G$2:$G$" & ZeileMax & ")"
Next
Application.DisplayAlerts = xAlerts
ActiveWorkbook.Save
If Monat = "Januar" Then
Workbooks.Add.SaveAs Filename:=DokNameYear
Else
Workbooks.Open(DokNameYear).Activate
End If
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each xSht In ThisWorkbook.Sheets
If Monat = "Januar" Then
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = xSht.Name
WorkB.Worksheets("Finn Comfort").Range("A1:G1").Copy
ActiveSheet.Range("A1:G1").PasteSpecial (xlPasteFormats)
ActiveSheet.Range("D1:G1").PasteSpecial (xlPasteFormats)
ActiveSheet.Range("A1:G1").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("F1").Value = "EP"
ActiveSheet.Range("F2:F200").NumberFormat = "$ #,##0.00"
ActiveSheet.Range("G1").Value = "Summe"
ActiveSheet.Range("G2:G200").NumberFormat = "$ #,##0.00"
ActiveSheet.Range("A2:G200").FormatConditions.Add Type:=xlExpression, Formula1:="=UND((ISTLEER($F2)=WAHR);(ISTLEER($E2)=FALSCH))"
ActiveSheet.Range("A2:G200").FormatConditions(ActiveSheet.Range("A2:G200").FormatConditions.Count).SetFirstPriority
With ActiveSheet.Range("A2:G200").FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
ActiveSheet.Range("A2:G200").FormatConditions(1).StopIfTrue = False
Else
End If
ZeileMax = Workbooks(DokName).Worksheets(xSht.Name).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(xSht.Name).Activate
If ZeileMax > 1 Then
ActiveSheet.Range("A2").EntireRow.Resize(ZeileMax - 1, 7).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
ActiveSheet.Range("A2").Resize(ZeileMax - 1, 7).Value = Workbooks(DokName).Worksheets(xSht.Name).Range("A2:G" & ZeileMax).Value
Else
End If
Next
Application.DisplayAlerts = xAlerts
ActiveWorkbook.Close SaveChanges:=True
Workbooks("Preisliste.xlsm").Close SaveChanges:=False
End Sub