AW: Makro, Tabellenblätter vereinen als CSV-Datei
01.02.2014 05:07:20
fcs
Hallo Tim,
hier zwei Makro-Variationen, die die Funktionalität haben.
Gruß
Franz
Sub Alle_in_1_Blatt_plus_CSV()
'Daten aus Tabellenblättern in einer Arbeitsmappe auf Baasis einer Namensliste in _
einem Tabellenblatt zusammenführen und als CSV speichern
Dim lngZeile As Long, lngZeileZ As Long
Dim wkbAktiv As Workbook, wks As Worksheet, wksListe As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim rngCopy As Range
Set wkbAktiv = ActiveWorkbook
Dim varName
Set wksListe = wkbAktiv.Worksheets("Blattliste") 'Tabelle mit den Blattnamen
With wksListe
'Liste der Blattnamen abarbeiten
For lngZeile = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set wks = wkbAktiv.Worksheets(wksListe.Cells(lngZeile, 1).Text)
If wkbZiel Is Nothing Then
'1. Blatt mit allen Daten in neue Mappe kopieren
wks.Copy
Set wkbZiel = ActiveWorkbook
Set wksZiel = wkbZiel.Sheets(1)
With wksZiel
.Name = "Alle_CSV"
'nächste nicht benutzte Zeile im Blatt
lngZeileZ = .UsedRange.Row + .UsedRange.Rows.Count
End With
Else
With wks
'Daten in Spalten A bis C ab Zeile 2 kopieren
Set rngCopy = .Range(.Cells(2, 1), _
.Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, 3))
End With
rngCopy.Copy wksZiel.Cells(lngZeileZ, 1)
'nächte Einfügezeile berechnen
lngZeileZ = lngZeileZ + rngCopy.Rows.Count
End If
Next
End With
wkbZiel.Activate
'Speichername auswählen/eingeben
varName = Application.GetSaveAsFilename( _
InitialFileName:="ALLE" & Format(Date, "YYYYMMDD"), _
Filefilter:="CSV-Datei (*.csv),*.csv", _
Title:="Bitte Name der CSV-Datei auswählen/eingeben")
If varName False Then
Application.DisplayAlerts = False
wkbZiel.SaveAs Filename:=varName, FileFormat:=xlCSV, Local:=True, addtomru:=True
wkbZiel.Close savechanges:=False
Application.DisplayAlerts = True
End If
End Sub
Sub Alle_in_1_Blatt_plus_CSV_2()
'Daten aus Tabellenblättern in einer Arbeitsmappe in _
einem Tabellenblatt zusammenführen und als CSV speichern
Dim lngZeileZ As Long
Dim wkbAktiv As Workbook, wks As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim rngCopy As Range
Set wkbAktiv = ActiveWorkbook
Dim varName
For Each wks In wkbAktiv.Worksheets
Select Case wks.Name
Case "Blattliste", "Muster"
'Daten aus diesen Blättern nicht mit kopieren
Case Else
If wkbZiel Is Nothing Then
'1. Blatt mit allen Daten in neue Mappe kopieren
wks.Copy
Set wkbZiel = ActiveWorkbook
Set wksZiel = wkbZiel.Sheets(1)
With wksZiel
.Name = "Alle_CSV"
'nächste nicht benutzte Zeile im Blatt
lngZeileZ = .UsedRange.Row + .UsedRange.Rows.Count
End With
Else
With wks
'Daten in Spalten A bis C ab Zeile 2 kopieren
Set rngCopy = .Range(.Cells(2, 1), _
.Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, 3))
End With
rngCopy.Copy wksZiel.Cells(lngZeileZ, 1)
'nächte Einfügezeile berechnen
lngZeileZ = lngZeileZ + rngCopy.Rows.Count
End If
End Select
Next
wkbZiel.Activate
'Speichername auswählen/eingeben
varName = Application.GetSaveAsFilename( _
InitialFileName:="ALLE" & Format(Date, "YYYYMMDD"), _
Filefilter:="CSV-Datei (*.csv),*.csv", _
Title:="Bitte Name der CSV-Datei auswählen/eingeben")
If varName False Then
'Datei als CSV speichern und schliessen
wkbZiel.SaveAs Filename:=varName, FileFormat:=xlCSV, Local:=True, addtomru:=True
Application.DisplayAlerts = False
wkbZiel.Close savechanges:=False
Application.DisplayAlerts = True
End If
End Sub