AW: Daten - Pivotabelle - Assisten folgen. Fertig
27.03.2010 17:56:03
fcs
Hallo Horst,
Hier mal eine angepasste Fassung inkl. Speichern des Tabellenblatts im Textformat. Gewünschtes Format muss du durch Anpassung der als Kommentar schon eingefügten Zeilen noch festlegen.
Beim Start des Makros muss das tabellenblatt mit den zu filternden Daten aktiv sein.
Gruß
Franz
Sub ExportSpalteFilter()
Dim wks As Worksheet, wksResult As Worksheet, LastRow As Long
Dim vAuswahl As Variant, wbResult As Workbook, sDatei As String
On Error GoTo Fehler
Set wks = ActiveSheet
Set wksResult = Sheets("result")
With wksResult
.UsedRange.ClearContents
End With
With wks
If .FilterMode = True Then
If .Rows.Count _
Cells.SpecialCells(xlCellTypeVisible).EntireRow.Rows.Count Then
.ShowAllData
End If
End If
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
End With
Cells(1, 1).Select
Selection.AutoFilter Field:=3, Criteria1:="1"
wks.Range("AQ1:CD" & LastRow).Copy Destination:=wksResult.Cells(1, 1)
ActiveWorkbook.Save
wksResult.Activate
'Dateinamen für Exportdatei wählen
vAuswahl = Application.GetSaveAsFilename(InitialFileName:="TextExport.Txt", _
FileFilter:="Text(*.txt),*.txt", _
Title:="Bitte Dateinamen für Text-Export-Datei auswählen/eingeben")
If vAuswahl False Then
'Dateinamen merken
sDatei = ActiveWorkbook.FullName
Set wbResult = ActiveWorkbook
'Aktives Tabellenblatt als Textdatei speichern
'xlUnicodeText
wbResult.SaveAs Filename:=vAuswahl, FileFormat:=42
'xlUnicodeText mit lokalen Einstellungen für Dezimalzeichen und Trennzeichen
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=42, Local:=True
'xlTextMSDOS MSDOS-Text
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=21
'xlTextPrinter Druckertext (Zwischen Spalten werden Leerzeichen eingefügt, _
Zeichenzahl pro Zeile ist begrenzt
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=36
'xlTextWindows Windows Text
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=20
'xlCSV CSV-Format - mit US-Einstellungen für Dezimal- und Trennzeichen
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=6, Local:=False
'xlCSV CSV-Format mit lokalen Einstellungen für Dezimalzeichen und Trennzeichen
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=6, Local:=True
'xlCSVWindows CSV(Windows)
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=23
'xlCSVWindows CSV(Windows) mit lokalen Einstellungen für Dezimalzeichen _
und Trennzeichen
' wbResult.SaveAs Filename:=vAuswahl, FileFormat:=23, Local:=True
Workbooks.Open Filename:=sDatei
wbResult.Close savechanges:=False
End If
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr. " & .Number & vbLf & .Description
End Select
End With
End Sub