Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1908to1912
1908to1912
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

2 Arbeitsblätter exportieren VBA

Forumthread: 2 Arbeitsblätter exportieren VBA

2 Arbeitsblätter exportieren VBA
15.12.2022 09:38:30
Tom
Hallo und guten Morgen,
aus einer Datei sollen 2 Arbeitsblätter anhand der Spalte A in separat zu erstellende Dateien exportiert werden, die neuen 2 Arbeitsblätter sollen jeweils die gleiche Bezeichnung erhalten wie die Ursprungsdatei, also jeweils "Angest." und "Sonst.". Das Makro, dass ich hier im Forum gefunden habe, liefert grds. genau die richtigen Ergebnisse. Leider wird nur immer das 1. Arbeitsblatt exportiert und die Bezeichnung nicht übernommen. Hier die Datei: https://www.herber.de/bbs/user/156742.xlsm
Hat jemand eine Idee, wie das Makro anzupassen ist? Mir ist es leider mit meinen bescheidenen VBA Kenntnissen nicht gelungen.
Viele Grüße
Tom
Anzeige

17
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 2 Arbeitsblätter exportieren VBA
15.12.2022 09:54:49
Rudi
Hallo,
teste mal:

Sub IndikatorenExportieren()
Dim dicIdentNo As Object
Dim strIdentNo As String
Dim arrIdentNo As Variant
Dim lngLastRow As Long, i As Long
Set dicIdentNo = CreateObject("Scripting.Dictionary")
Dim wks As Worksheet
'AutoFilter in Spalte A einrichten
For Each wks In Sheets(Array("Angest.", "Sonst."))
dicIdentNo.RemoveAll
With wks
.Columns("A:A").AutoFilter
If Not .AutoFilterMode Then
.Columns("A:A").AutoFilter
End If
'Letzte Zeile ermitteln
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Alle Indikator ermitteln
For i = 2 To lngLastRow
strIdentNo = Trim(.Cells(i, 1).Text)
dicIdentNo(strIdentNo) = 0
Next i
'Alle Indikatoren in Array übertragen
arrIdentNo = dicIdentNo.keys
'Jeden Indikator filtern und in neuer Arbeitsmappe speichern
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 0 To UBound(arrIdentNo)
.Cells(1, 1).AutoFilter Field:=1, Criteria1:=arrIdentNo(i)
.Cells.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
ActiveSheet.Paste
Columns.AutoFit
Range("A1").Select
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & wks.Name & "_" & arrIdentNo(i), FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next i
End With
Next wks
Application.Calculation = xlCalculationAutomatic
End Sub
Gruß
Rudi
Anzeige
AW: 2 Arbeitsblätter exportieren VBA
15.12.2022 10:06:16
Tom
Hallo Rudi,
klappt leider nicht. Die Arbeitsblätter werden alle einzeln exportiert, haben einen unbekannten Dateityp und sind mit 18 MB auch sehr groß.
Idealerweise sollte das Ergebnis so aussehen: https://www.herber.de/bbs/user/156743.xlsm
Viele Grüße
Tom
Anzeige
AW: 2 Arbeitsblätter exportieren VBA
15.12.2022 11:15:06
Rudi
Hallo,
dann:

Option Explicit
Sub IndikatorenExportieren()
Dim dicIdentNo As Object, oDic
Dim lngLastRow As Long, lngRow As Long
Dim wks As Worksheet, wkbNeu As Workbook
Dim arrSheets
Dim arrDaten
Set dicIdentNo = CreateObject("Scripting.Dictionary")
arrSheets = Array("Angest.", "Sonst.")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'AutoFilter in Spalte A einrichten
For Each wks In ThisWorkbook.Sheets(arrSheets)
With wks
.Columns(1).AutoFilter
If Not .AutoFilterMode Then
.Columns(1).AutoFilter
End If
'Letzte Zeile ermitteln
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Alle Indikatoren ermitteln
For lngRow = 2 To lngLastRow
dicIdentNo(.Cells(lngRow, 1).Text) = 0
Next lngRow
End With
Next wks
'Jeden Indikator filtern und in neuer Arbeitsmappe speichern
For Each oDic In dicIdentNo
Set wkbNeu = Workbooks.Add(1)
ActiveSheet.Name = arrSheets(1)
wkbNeu.Worksheets.Add.Name = arrSheets(0)
For Each wks In ThisWorkbook.Sheets(arrSheets)
With wks
.Range("A1").AutoFilter Field:=1, Criteria1:=oDic
arrDaten = .Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible)
With wkbNeu.Sheets(wks.Name)
.Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten
.Columns.AutoFit
.Range("A1").Copy
.Range("A1").PasteSpecial xlPasteFormats
End With
End With
Application.CutCopyMode = False
Next wks
With wkbNeu
.SaveAs _
Filename:=ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, ".xlsm", "") & "_" & oDic, _
FileFormat:=xlOpenXMLWorkbook
.Close
End With
Set wkbNeu = Nothing
Next oDic
Application.Calculation = xlCalculationAutomatic
End Sub
Gruß
Rudi
Anzeige
AW: 2 Arbeitsblätter exportieren VBA
15.12.2022 12:55:27
snb
Vorschlag:

Sub M_snb()
Sheets.Add , Sheets(Sheets.Count)
With Tabelle1
.Columns(1).AdvancedFilter 2, , .Cells(1, 40), 1
With .Cells(1, 40).CurrentRegion
sn = .Value
.ClearContents
End With
With .Cells(1).CurrentRegion
For j = 2 To UBound(sn)
.AutoFilter 1, sn(j, 1)
.Copy Sheets(Sheets.Count).Cells(1)
.AutoFilter
Sheets(Sheets.Count).Copy
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & sn(j, 1), 51
.Close
End With
Sheets(Sheets.Count).UsedRange.Clear
Next
End With
End With
End Sub

Anzeige
AW: 2 Arbeitsblätter exportieren VBA
15.12.2022 13:48:19
Tom
Hallo snb,
leider auch nicht ganz, es fehlen jeweils die 2. Arbeitsblätter aus der Originaldatei mit den jeweiligen Bezeichnungen "Angest."und "Sonst.".
Viele Grüße
Tom
Aufgabenstellung,
15.12.2022 15:06:20
Yal
Moin alle,
Tom hat eine Workbook mit 2 Worksheets.
In Spalte A jeden Worksheets sind verschiedene Einträge (1, 2, 3, ..)
Pro Eintrag soll ein neues WB mit diesen 2 Worksheets, aber nur die entsprechenden Einträge:
WB 1, 2 Blätter, nur die Einträge mit "1"
WB 2, 2 Blätter, nur die Einträge "2"
usw.
ob man kopiert und dann löscht, oder gezielt hinkopiert? Das Spiel ist eröffnet! (ich mache nicht mit, weil ich vor kurzem genau das schon gemacht)
VG
Yal
Anzeige
Datei pro Schlüssel speichern
15.12.2022 16:27:30
Yal
Niemand? da bin ich enttäuscht.

Sub IndikatorenExportieren()
Dim dicIdentNo As Object
Dim ws As Worksheet
Dim WB As Workbook
Dim Dateiname As String
Dim Elt, i 'Laufvariablen
'Alle Indikatoren eindeutig ermitteln
Set dicIdentNo = CreateObject("Scripting.Dictionary")
For Each ws In Sheets(Array("Angest.", "Sonst."))
ws.Columns("A:A").AutoFilter 'Reset Filter, 1 v. 2
If Not ws.AutoFilterMode Then ws.Columns("A:A").AutoFilter 'Reset Filter, 2 v. 2
'Dictionary aufbauen (Eindeutigkeit durch Dictionary-Schlüssel gewährleistet)
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row 'von Zeile 2 bis letzte Zeile
dicIdentNo(Trim(ws.Cells(i, 1).Text)) = 0
Next i
Next
'für jede eindeutige Eintrag
For Each Elt In dicIdentNo.Keys
'als neue, spezifische Datei speichern
Dateiname = Replace(ThisWorkbook.FullName, ".xls", "_" & Elt & ".xls")
ThisWorkbook.SaveCopyAs Dateiname
'Datei öffnen
Set WB = Workbooks.Open(Dateiname)
'in jeden Blatt Einträge löschen, die nicht relevante sind
For Each ws In Sheets(Array("Angest.", "Sonst."))
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'von letzte Zeile bis 2te (beim löschen, immer rückwärts)
If Trim(ws.Cells(i, 1).Text)  Elt Then ws.Rows(i).Delete
Next
Next
'spezifische Datei speichern und schliessen
WB.Save
WB.Close
Next
End Sub
Ungetestet. Vielleicht nach 2 Dateien zuerst prüfen, bevor man die Festplatte vermüllt wird.
VG
Yal
Anzeige
Niemand?
16.12.2022 09:03:37
Rudi
Hallo,
doch.
Siehe meinen von 11:15:06, der anscheinend ignoriert wird.
Gruß
Rudi
Die Krohne geht an Rudi
16.12.2022 09:14:13
Yal
Oops! Total übersehen. Asche über meinen Haupt!
Deine Lösung ist genau die "andere" Methode: nur die gewollte Einträge übertragen (ich übertrage und lösche die ungewollten).
Damit geht die virtuelle Krohne an Dich!
Wäre schön, wenn Tom auch einen Satz dazu sagen könnte.
VG
Yal
Anzeige
AW: Die Krohne geht an Rudi
16.12.2022 09:33:44
Rudi
Danke, aber ich nehme mir ein h.
Krone, nicht Krohne. ;-)
Gruß
Rudi
... der Kompiler hat nicht gemekert ;-) owT
16.12.2022 09:44:26
Yal
AW: Die Krohne geht an Rudi
16.12.2022 10:28:25
Tom
Hallo Yal und Rudi,
ich hatte gestern Abend noch geantwortet, aber das scheint wohl nicht angekommen zu sein, wie ich gerade gesehen habe. Leider kann ich das Makro von Yal auf meinem Firmenrechner nicht ausführen, vielleicht wg. Virenschutz oder sowas. Bei den anderen Lösungsansätzen ging es. Könnte man das vielleicht etwas umbasteln, wie auch immer geartet?
Viele Grüße
Tom
Anzeige
AW: Die Krohne geht an Rudi
16.12.2022 10:44:06
Yal
Hallo Tom,
wenn deine bisherige Makro funktioniert, dann liegt es nicht an der Makro selbst. So feingranular sind die Schutzmechanismen nicht.
Meine Vermutung ist, dass die Datei in irgendeinem Verzeichnis abgelegt worden ist, der nicht zu der "vertrauenwürdige Quellen" gehört.
Wenn Du alles lokal speicherst, solltest Du normalerweise kein Problem haben.
VG
Yal
Anzeige
AW: Die Krohne geht an Rudi
16.12.2022 11:04:05
Tom
Hallo Yal,
ich hab die Datei bei mir auf dem Desktop, von dort hab ich die anderen vorgeschlagenen Makros in der Datei auch getestet, da gab es keine Probleme. Kann ich mir ehrlich gesagt nicht ganz erklären. Gibt es vielleicht doch noch eine alternativen Lösung? Vielleicht auf der Basis von Rudis Makro?
Viele Grüße
Tom
Anzeige
hast du denn...
17.12.2022 19:01:19
Rudi
... meinen 2. Code ausprobiert?
Gruß
Rudi
AW: hast du denn...
19.12.2022 09:28:39
Tom
Hallo Rudi,
ausprobiert hatte ich ihn am Freitag, aber leider verschlampt, dir eine Rückmeldung zu geben, sorry. Grundsätzlich funktioniert er, aber nur bei Arbeitsmappe 1, die anderen sind leer. Die Mappen sollten zudem nur die Bezeichnung "1", "2" etc. haben, aktuell ist der Dateiname noch mit dabei.
Viele Grüße
Tom
Anzeige
AW: hast du denn...
21.12.2022 10:49:24
Tom
Hallo zusammen,
hat keiner eine Idee?
Viele Grüße
Tom
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige