Option
Explicit
Sub
anlagenEinzelnExcel()
Dim
RG_Nr
As
Integer
Dim
countRow
As
Double
Dim
i
As
Double
Dim
cellnumeric
As
Boolean
Dim
RG_Column
As
Long
Dim
rgWs
As
Worksheet
Set
rgWs = ThisWorkbook.Worksheets(
"RG-Anlage"
)
Dim
Blatt
As
Worksheet
For
Each
Blatt
In
ThisWorkbook.Worksheets
If
Blatt.Name =
"AnlagenTab"
Then
GoTo
Weiter
End
If
Next
Blatt
Weiter:
Worksheets(
"RG-Anlage"
).Activate
i = 7
countRow = 7
RG_Column = Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 2
Cells(countRow, RG_Column).Activate
Do
Until
ActiveCell.Value = 0
Cells(countRow, RG_Column).Activate
RG_Nr = ActiveCell.Value
countRow = countRow + 1
Loop
countRow = countRow - 8
Dim
currentColumn
As
Double
Dim
pastColumnValue
As
Integer
Dim
countRange
As
Integer
Dim
aktuelleSpaltenZahl
As
Integer
Dim
j
As
Double
Dim
strPrintArea
As
String
Dim
druckZeile
As
String
countRange = 0
currentColumn = 7
Cells(currentColumn, RG_Column).Activate
RG_Nr = ActiveCell.Value
For
j = 0
To
countRow - 1
Worksheets(
"RG-Anlage"
).Activate
Worksheets(
"RG-Anlage"
).Cells(currentColumn, RG_Column).Activate
If
ActiveCell.Value > RG_Nr
Then
Call
CreateExcelAnlagen(Worksheets(
"RG-Anlage"
).Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
RG_Nr = RG_Nr + 1
currentColumn = currentColumn + 1
countRange = 1
ElseIf
ActiveCell.Value < RG_Nr
Then
Exit
For
ElseIf
ActiveCell.Value = RG_Nr
Then
currentColumn = currentColumn + 1
countRange = countRange + 1
End
If
Next
j
Call
CreateExcelAnlagen(Worksheets(
"RG-Anlage"
).Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
Worksheets(
"RG-Anlage"
).Activate
End
Sub
Private
Function
CreateExcelAnlagen(rRange
As
Range, RGNr
As
Integer
, KundenNr
As
Long
)
Dim
tabWs
As
Worksheet
Dim
strPfad
As
Variant
strPfad = ThisWorkbook.Path &
"\" & "
anlagen_excel"
ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
Worksheets(Sheets.Count).Name =
"AnlagenTab"
Set
tabWs = ThisWorkbook.Worksheets(
"AnlagenTab"
)
With
tabWs
.Activate
.Cells(2, 1).Value =
"Kundennummer: "
& KundenNr
.Cells(3, 1).Value =
"Rechnungsnummer: "
& Year(
Date
) &
"-"
& RGNr
.Cells(4, 1).Value =
"Datum: "
&
Date
Worksheets(
"RG-Anlage"
).Activate
Worksheets(
"RG-Anlage"
).Range(Cells(6, 2), Cells(6, Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 1)).Copy
.Activate
.Cells(6, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(6, 1).PasteSpecial Paste:=xlPasteValues
rRange.Copy
.Cells(7, 1).PasteSpecial Paste:=xlPasteColumnWidths, SkipBlanks:=
True
.Cells(7, 1).PasteSpecial Paste:=xlFormats
.Cells(7, 1).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=
True
End
With
With
tabWs.Cells(1, 1)
.Value =
"Anlage zu Rechnung"
.Font.Size = 12
.Font.Bold =
True
End
With
With
tabWs.Cells(1, tabWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column)
.Value =
"WATERcontrol AG"
& vbCrLf &
"Alter Flughafen 16 B"
& vbCrLf &
"30179 Hannover"
.EntireColumn.AutoFit
.Font.Bold =
True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End
With
With
tabWs.Cells(1, 1).EntireRow
.Font.Bold =
True
.VerticalAlignment = xlCenter
End
With
With
Cells(6, 1).CurrentRegion
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.BorderAround Weight:=xlThick
End
With
With
Cells(6, 1).EntireRow
.Font.Bold =
True
.WrapText =
True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End
With
With
tabWs.PageSetup
.Zoom =
False
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End
With
If
Dir(strPfad, vbDirectory) <>
""
Then
Else
MkDir strPfad
End
If
tabWs.SaveAs Filename:=strPfad & "\" & RGr, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts =
False
Worksheets(
"AnlagenTab"
).Delete
Application.DisplayAlerts =
True
End
Function
Private
Function
KundenNr()
As
Long
Dim
i
As
Integer
Dim
KDNr
As
Long
Dim
geWs
As
Worksheet
Set
geWs = ThisWorkbook.Worksheets(
"gesamtexport"
)
For
i = 1
To
geWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column
If
geWs.Cells(1, i) =
"KDNummer"
Then
KDNr = geWs.Cells(2, i).Value
Exit
For
End
If
Next
i
KundenNr = KDNr
End
Function