Code Anpassung - Zeile hinzufuegen
22.03.2017 14:49:52
Gerhardt
ich habe einen kleinen Code, der die Spalte A1 sortiert und fuer jedes Sortierergebnis eine PDF Datei erstellt. Nun soll zusaetzlich noch die Zeile 2575 in jedes Blatt mitkopiert werden. Die Zeile enthaelt eine Summenformel, die immer die Summe fuer die SOrtiervorschlaege ausgibt. Kann jemand diese kleine Aenderung im Code vornehmen?
Code:
Option Explicit
Sub FilterAndPDF()
Dim ItemList As Variant
Dim i As Long
ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Name = "DataList" 'anpassen
Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
FindUniqueItems ItemList, "DataList"
ActiveSheet.Range("DataList").AutoFilter
For i = 1 To UBound(ItemList)
ActiveSheet.Range("DataList").AutoFilter 1, ItemList(i)
Application.StatusBar = "PDF " & ItemList(i)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & Application.PathSeparator & ItemList(i) & ".pdf", Quality:=xlQualityStandard _
, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next i
Application.StatusBar = False
ActiveSheet.ShowAllData
End Sub
Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
Dim TempList() As String, UniqueCount As Integer, cl As Range, i As Integer
Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
ReDim TempList(1 To UniqueCount - 1)
i = 0
For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
i = i + 1
If i > 1 Then TempList(i - 1) = cl.Formula
Next cl
Set cl = Nothing
UniqueItems = TempList
End Sub
Vielen Dank fuer die Unterstuetzung!!!VG Gerhardt