Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel Datei Filtern und Inhalt als CSV speichern

Excel Datei Filtern und Inhalt als CSV speichern
21.01.2015 12:35:11
saspoe
Hallo Forum,
wie komme ich dies mit VBA gelöst?
Ich habe eine Datei in der Form: Kunde (Spalte A), Artikel (Spalte B), IndividuellerPreis (Spalte C)
In dem Tabellenblatt befinden sich alle Kunden/Artikelkombinationen, insgesamt 280.000 Zeilen.
Nun möchte ich daraus pro Kunden eine separate XLS oder CSV-Datei generieren, in der nur seine Artikel-und Preisinformationen auftauchen. Die neue Datei soll so heißen wie der Eintrag in Spalte A.
Die Anforderung gab es so ähnlich sicherlich schon, mir fehlt jedoch grad die richtige Idee.
Danke für eure Hilfe
Sas
Eine Beispiel-Datei ist hier: https://www.herber.de/bbs/user/95140.xls

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Datei Filtern und Inhalt als CSV speichern
21.01.2015 13:11:48
Klaus
Hallo Sas,
Kommentare direkt im Code. Ich benutze den Autofilter und schalte ihn am Codeende wieder ab - also nicht wundern, falls du einen eigenen Filter gesetzt hattest.
Option Explicit
Sub FiltereMeier()
Call FilterNachNameCSVDatei("Meier")
'wie du nach Schulz und Müller filterst ist dann klar, oder?
End Sub
Sub FilterNachNameCSVDatei(KundeName As String)
Const SpeicherPfad As String = "U:\herbers"     'anpassen
Const SpeicherAls As String = "KundenFilter"    'anpassen
Const wksQuelle As String = "Tabelle1"          'anpassen
Const FilterSpalte As Long = 1                  'in A filtern
Const ersteZeile As Long = 1                    'Überschriften in Zeile 1
Dim letzteZeile As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim SpeicherName As String
Application.ScreenUpdating = False
'aktuelles Blatt merken
Set wkbOld = ActiveWorkbook
'immer eindeutigen Dateinamen ermitteln mit Datum und Uhrzeit
SpeicherName = KundeName & "_" & Format(Date, "yymmdd") & "_" & Format(Time, "hhmmss") & "_" &  _
SpeicherAls
With Sheets(wksQuelle)
'Autofilter setzen, nach Kunde filtern, sichtbare Zellen kopieren
Call DoResetAutofilter(Sheets(.Name), FilterSpalte, FilterSpalte, ersteZeile)
.Cells(ersteZeile, FilterSpalte).AutoFilter Field:=1, Criteria1:=KundeName
letzteZeile = .Cells(.Rows.Count, FilterSpalte).End(xlUp).Row
.Range(.Cells(ersteZeile, 1), .Cells(letzteZeile, 1)).SpecialCells(xlCellTypeVisible).Copy
End With
'neues Workbook erstellen
Workbooks.Add
Set wkbNew = ActiveWorkbook
With wkbNew
'Zwischenablage einfügen, als CSV speichern und schließen
.ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ChDir SpeicherPfad
.SaveAs Filename:=SpeicherPfad & "\" & SpeicherName & ".csv", FileFormat:=xlCSVMSDOS
.Close True
End With
With Sheets(wksQuelle)
'Autofilter wieder abschalten
If .AutoFilterMode Then .Cells.AutoFilter
End With
'Zur Sicherheit: altes Workbook wieder aktivieren, falls ein anderes Fenster vorne ist
wkbOld.Activate
Application.ScreenUpdating = True
End Sub
Sub DoResetAutofilter(wksMySheet As Worksheet, iColFirst As Integer, iColLast As Integer,  _
lRowFirst As Long)
'* in case a user used another autofiler, this makro resets the autofilter to where needed.
Dim lRowLast As Long
With wksMySheet
lRowLast = .Cells(.Rows.Count, iColFirst).End(xlUp).Row
If .AutoFilterMode Then .Cells.AutoFilter 'Turns OFF Autofilter, if any
.Range(.Cells(lRowFirst, iColFirst), .Cells(lRowLast, iColLast)).AutoFilter 'Turns ON  _
Autofilter on given range
End With
End Sub
Grüße,
Klaus M.vdT.

Anzeige
Sorry - Mini-Korrektur
21.01.2015 13:14:02
Klaus
Natürlich musst du wkbOld erst aktivieren, bevor du den Autofilter wieder abschalten kannst.
Nochmal das ganze:
Option Explicit
Sub FiltereMeier()
Call FilterNachNameCSVDatei("Meier")
'wie du nach Schulz und Müller filterst ist dann klar, oder?
End Sub
Sub FilterNachNameCSVDatei(KundeName As String)
Const SpeicherPfad As String = "U:\herbers"     'anpassen
Const SpeicherAls As String = "KundenFilter"    'anpassen
Const wksQuelle As String = "Tabelle1"          'anpassen
Const FilterSpalte As Long = 1                  'in A filtern
Const ersteZeile As Long = 1                    'Überschriften in Zeile 1
Dim letzteZeile As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim SpeicherName As String
Application.ScreenUpdating = False
'aktuelles Blatt merken
Set wkbOld = ActiveWorkbook
'immer eindeutigen Dateinamen ermitteln mit Datum und Uhrzeit
SpeicherName = KundeName & "_" & Format(Date, "yymmdd") & "_" & Format(Time, "hhmmss") & "_" &  _
SpeicherAls
With Sheets(wksQuelle)
'Autofilter setzen, nach Kunde filtern, sichtbare Zellen kopieren
Call DoResetAutofilter(Sheets(.Name), FilterSpalte, FilterSpalte, ersteZeile)
.Cells(ersteZeile, FilterSpalte).AutoFilter Field:=1, Criteria1:=KundeName
letzteZeile = .Cells(.Rows.Count, FilterSpalte).End(xlUp).Row
.Range(.Cells(ersteZeile, 1), .Cells(letzteZeile, 1)).SpecialCells(xlCellTypeVisible).Copy
End With
'neues Workbook erstellen
Workbooks.Add
Set wkbNew = ActiveWorkbook
With wkbNew
'Zwischenablage einfügen, als CSV speichern und schließen
.ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ChDir SpeicherPfad
.SaveAs Filename:=SpeicherPfad & "\" & SpeicherName & ".csv", FileFormat:=xlCSVMSDOS
.Close True
End With
'Zur Sicherheit: altes Workbook wieder aktivieren, falls ein anderes Fenster vorne ist
wkbOld.Activate
With Sheets(wksQuelle)
'Autofilter wieder abschalten
If .AutoFilterMode Then .Cells.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Sub DoResetAutofilter(wksMySheet As Worksheet, iColFirst As Integer, iColLast As Integer,  _
lRowFirst As Long)
'* in case a user used another autofiler, this makro resets the autofilter to where needed.
Dim lRowLast As Long
With wksMySheet
lRowLast = .Cells(.Rows.Count, iColFirst).End(xlUp).Row
If .AutoFilterMode Then .Cells.AutoFilter 'Turns OFF Autofilter, if any
.Range(.Cells(lRowFirst, iColFirst), .Cells(lRowLast, iColLast)).AutoFilter 'Turns ON  _
Autofilter on given range
End With
End Sub
Grüße,
Klaus M.vdT.
(ich sollte meine Beiträge erst lesen und dann abschicken statt anders herum)

Anzeige
AW: Sorry - Mini-Korrektur
21.01.2015 13:26:59
saspoe
Hallo Klaus,
vielen Dank für deine Mühe. Bei der Code-Durchsicht scheint es mir, dass ich die Filter hart im Code eintragen muss.
Hab das vermutlich nicht vernünftig erläutert, sorry.
Der Code soll in Spalte A schauen, dort den ersten Namen finden und danach filtern, alle zugehörigen Zeilen in eine neue Datei mit dem Kundennamen speichern.
Danach soll er dies mit dem nächsten gefundenen Kunden durchführen. Aktuell sind es an die 300 Kunden.
Gruß
Sas

AW: Sorry - Mini-Korrektur
21.01.2015 13:38:45
Klaus
Hi,
ja ich habe den Code so gehalten, dass er für jeden Namen einzeln ausgeführt werden kann. Wenn du die Namen nicht einzeln hart eintragen willst, ermittel doch ein eindeutiges Namensverzeichniss ohne Doppler per VBA und lasse den Code dann darüber laufen:
Option Explicit
Sub RufeMakroFuerJedenNamenEinmalAuf()
Const NamenSpalte As Long = 1                   'Namen stehen in A
Const ersteZeile As Long = 1                    'Überschriften in Zeile 1
Const QuelleBlatt As String = "Tabelle1"
Dim wksNew As Worksheet
Dim lZeile As Long
Dim xName As Long
'temporäres Blatt erstellen
Sheets.Add
Set wksNew = ActiveSheet
'Namensspalte kopieren
With Sheets(QuelleBlatt)
.Range(.Cells(ersteZeile, NamenSpalte), .Cells(ersteZeile, NamenSpalte).End(xlDown)).Copy
End With
With wksNew
'Namensspalte einfügen
.Range("A1").PasteSpecial xlPasteValues
'Per "Duplikate entfernen" eindampfen
lZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$1:$A$" & lZeile).RemoveDuplicates Columns:=1, Header:=xlNo
lZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Für jeden Namen das Makro aufrufen
For xName = 2 To lZeile
Call FilterNachNameCSVDatei(.Cells(xName, 1).Value)
Next xName
End With
'Temp-Blatt wieder los werden
Application.DisplayAlerts = False
wksNew.Delete
Application.DisplayAlerts = True
End Sub
Grüße,
Klaus M.vdT.

Anzeige
AW: Excel Datei Filtern und Inhalt als CSV speichern
21.01.2015 17:04:49
Rudi
Hallo,
meine Version ohne Filter:
Sub export()
Dim arrTmp, i As Long, j As Integer, objDic As Object, oDic
Dim strOut As String, strHeader As String, strTmp
Set objDic = CreateObject("Scripting.dictionary")
With Sheets(1).Range("A1").CurrentRegion
arrTmp = .Offset(1).Resize(.Rows.Count - 1)
strHeader = Join(Application.Transpose(Application.Transpose(.Rows(1))), ";") & vbCrLf
End With
For i = 1 To UBound(arrTmp)
objDic(arrTmp(i, 1)) = 0
Next
For Each oDic In objDic
strOut = strHeader
For i = 1 To UBound(arrTmp)
strTmp = ""
If arrTmp(i, 1) = oDic Then
For j = 1 To UBound(arrTmp, 2)
strTmp = strTmp & ";" & arrTmp(i, j)
Next
strTmp = Mid(strTmp, 2) & vbCrLf
strOut = strOut & strTmp
End If
Next i
Open "c:\test\" & oDic & ".csv" For Output As #1
Print #1, strOut
Close #1
Next oDic
End Sub

Gruß
Rudi

Anzeige
AW: Excel Datei Filtern und Inhalt als CSV speichern
21.01.2015 17:22:43
Daniel
Hi
wenn du die Datei sortierst, brauchst du sie nicht filtern sondern kannst blockweise die Daten in eine neue Tabelle kopieren und diese als CSV oder Excelfile speichern:
Sub KundenDateien()
Dim Zelle1 As Range
Dim Zelle2 As Range
With ActiveSheet
.UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
Set Zelle1 = .Range("A2")
Do While Zelle1.Value  ""
Set Zelle2 = .Columns(1).Find(what:=Zelle1.Value, lookat:=xlWhole, _
searchdirection:=xlPrevious)
Workbooks.Add template:=xlWBATWorksheet
.Rows(1).Copy ActiveSheet.Cells(1, 1)
Range(Zelle1, Zelle2).Resize(, 3).Copy ActiveSheet.Cells(2, 1)
ActiveWorkbook.SaveAs Zelle1.Value, FileFormat:=xlExcel8
ActiveWorkbook.SaveAs Zelle1.Value, FileFormat:=xlCSV, Local:=True
ActiveWorkbook.Close false
Set Zelle1 = Zelle2.Offset(1, 0)
Loop
End With
End Sub
Gruß Daniel

Anzeige
Schade ... :-/
23.01.2015 11:38:04
Klaus
.... ein relativ aufwendiger Code von mir, noch dazu zwei Varianten die etwas kompakter funktionieren. Man sollte denken dir wurde geholfen, SAS. Aber nach über zwei Tagen gibt es immer noch keine Rückmeldung. So macht es keinen Spass zu helfen.
Grüße,
Klaus M.vdT.

8 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige