AW: Excel VBA, Bestimmte Zeilen auswählen etc.
30.01.2017 21:28:18
fcs
Hallo Chris,
die Dateien der Städte kannst du mit folgendem Makro erstellen.
Die Dateien werden dabei im gleichen Verzeichnis erstellt wie die Datei mit allen Daten.
Das Einbinden der Datein in die PP-Präsentation ist dann nicht so einfach, wenn sich die Zeilenanzahl in den Dateien ändert. Wenn man die Datei als Objrkt einbinden, dann ist die Darstellung icht so doll und die Zahl der Zeilen pro PPP-Folie ist begrenzt.
Ich würde in der PPP für jede Stadt ein Rechteck einfügen und dem Rechteck einen Hyperlink auf die Excel-Datei zuweisen. Dann kann man die Exceldatei beim Absielen der Präsentation per Klick auf das jeweilige Rechteck öffnen.
LG
Franz
Sub CopyData_per_City()
Dim wkbAktiv As Workbook, wksData As Worksheet
Dim wksZiel As Worksheet, wkbZiel As Workbook
Dim Zeile As Long, Zeile_L As Long, Zeile_1 As Long
Dim arrData As Variant, arrNames As Variant
Dim colNames As New Collection
Dim strStadt As String, strLand As String, strDatei As String
On Error GoTo Fehler
'Datenquelle setzen
Set wkbAktiv = ActiveWorkbook
Set wksData = wkbAktiv.Worksheets(1)
Zeile_1 = 1 'Zeile mit Spalten-Überschriften
With wksData
'Autofilter anlegen wenn nicht vorhanden
If .AutoFilterMode = False Then
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
.Range(.Rows(1), .Rows(Zeile_L)).AutoFilter
Else
If .FilterMode = True Then .ShowAllData
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
End If
'Zellbereich mit Städten und Ländern in ein Daten-Array einlesen
arrData = .Range(.Cells(Zeile_1 + 1, 6), .Cells(Zeile_L, 8))
'Alle Städte/Länder in einen Collection-Objekt sammeln
For Zeile = LBound(arrData, 1) To UBound(arrData, 1)
colNames.Add Item:=arrData(Zeile, 1) & "|" & arrData(Zeile, 3), _
Key:=arrData(Zeile, 1) & "|" & arrData(Zeile, 3)
Next Zeile
'Städte/Länder abarbeiten
For Zeile = 1 To colNames.Count
'Stadt und Land aus Collection-Zeilen ermitteln
strStadt = Split(colNames(Zeile), "|")(0)
strLand = Split(colNames(Zeile), "|")(1)
'Dateiname für Stadt/Land-Datei
strDatei = wkbAktiv.Path & "\" & strStadt & "-" & strLand & ".xlsx"
'Prüfen, ob Datei schon vorhanden
If Dir(strDatei) "" Then
'vorhandenen Datei öffnen
Set wkbZiel = Workbooks.Open(Filename:=strDatei)
Else
'Datei neu anlegen und speichern
wksData.Copy
Set wkbZiel = ActiveWorkbook
wkbZiel.SaveAs Filename:=strDatei, FileFormat:=51, addtomru:=False
End If
'Zieltabellenblatt setzen
Set wksZiel = wkbZiel.Worksheets(1)
'vorhandene Daten löschen
wksZiel.UsedRange.Clear
'Daten in Quellblatt filtern und ins Zielblatt kopieren
wksData.AutoFilter.Range.AutoFilter Field:=6, Criteria1:=strStadt
wksData.AutoFilter.Range.AutoFilter Field:=8, Criteria1:=strLand
wksData.AutoFilter.Range.Copy wksZiel.Cells(1, 1)
'Daten im zielblatt als Tabelle/Listobject definieren
With wksZiel
Zeile_L = .Cells(1, 6).End(xlDown).Row
.ListObjects.Add SourceType:=xlSrcRange, _
Source:=wksZiel.Range(.Cells(1, 1), .Cells(Zeile_L, 8)), _
xllistobjecthasheaders:=xlYes
.ListObjects(1).Name = "Tab_City"
End With
'Zieldatei speichern und schliessen
wkbZiel.Close savechanges:=True
'alle Daten anzeigen
.ShowAllData
Next
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Wert in Collection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub