AW: Automatisiertes filtern und abspeichern
15.06.2015 18:37:14
Sepp
Hallo Christopher,
so, jetzt läuft es auch bei mehr Zeile als Spalten! Die Formel habe ich auch angepasst.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub transposeAndExport()
Dim rng As Range, rngC As Range, objWB As Workbook, objSH As Worksheet, objSHTmp As Worksheet
Dim vntUniqe As Variant, vntTmp As Variant
Dim strExportPath As String
Dim lngI As Long, lngSheetCount As Long, lngLast As Long
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
lngSheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 2
strExportPath = "E:\Forum\Test3\"
strExportPath = strExportPath & IIf(Right(strExportPath, 1) = "\", "", "\")
With Tabelle1
Set rng = .Range("A1").CurrentRegion
vntTmp = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
vntUniqe = toArrayUnique(vntTmp)
For lngI = LBound(vntUniqe) To UBound(vntUniqe)
Application.StatusBar = "Exportiere Datei " & lngI + 1 & " von " & UBound(vntUniqe) + 1 & " : " & "Firma_" & vntUniqe(lngI) & ".xlsx"
Set objWB = Workbooks.Add
Set objSH = objWB.Sheets(1)
Set objSHTmp = objWB.Sheets(2)
rng.AutoFilter Field:=1, Criteria1:=vntUniqe(lngI)
Set rngC = rng.SpecialCells(xlCellTypeVisible)
rngC.Copy
objSHTmp.Range("A1").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
objSHTmp.Range("A1").CurrentRegion.Resize(RowSize:=Application.Min(objSH.Columns.Count - 1, objSHTmp.Range("A1").CurrentRegion.Rows.Count)).Copy
objSH.Range("A1").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
objSH.Columns.AutoFit
objSH.Cells(1, 3).Resize(1, objSH.Columns.Count - 3) = ""
lngLast = Application.Max(3, objSH.Cells(objSH.Rows.Count, 1).End(xlUp).Row)
objSH.Columns(1).Insert
objSH.Cells(2, 1) = "Mittelwert"
objSH.Cells(3, 1).FormulaArray = "=IFERROR(AVERAGE(IF((ISNUMBER(C3:XFD3))*(C3:XFD3<>""""),C3:XFD3)),"""")"
objSH.Range(objSH.Cells(3, 1), objSH.Cells(lngLast, 1)).FillDown
objWB.SaveAs strExportPath & "Firma_" & vntUniqe(lngI) & ".xlsx"
objSHTmp.Delete
objSH.Cells(1, 1).Select
objWB.Close
Next
.ShowAllData
End With
MsgBox "Es wurden " & lngI & " Dateien nach '" & strExportPath & "' Exportiert!", vbInformation
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'transposeAndExport'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - transposeAndExport"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
If lngSheetCount > 0 Then .SheetsInNewWorkbook = lngSheetCount
End With
Set objWB = Nothing
Set objSH = Nothing
Set objSHTmp = Nothing
Set rng = Nothing
Set rngC = Nothing
End Sub
Public Function toArrayUnique(Field As Variant, Optional Sort As Integer = 1) As Variant
'Sort unsortiert = 0, sortiert A-Z = 1, sortiert Z-A = -1
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = LBound(Field, 1) To UBound(Field, 1)
For lngC = LBound(Field, 2) To UBound(Field, 2)
If Not .Contains(Trim(Field(lngR, lngC))) Then
If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
End If
Next
Next
If Sort <> 0 Then .Sort
If Sort < 0 Then .Reverse
toArrayUnique = .toArray
End With
Exit Function
ErrExit:
toArrayUnique = -1
End Function
Gruß Sepp
