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

Exceldatei splitten inkl. aller Formeln usw.

Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 16:21:46
Walter
Hallo, ich bin neu auf dem Gebiet, verzweifle aber leider leicht :-|
Ich habe folgenden Code im Netz gefunden, der auch super funktioniert, er erstellt bzw solitttet die Dateien un dlegt sie sauber ab. Aber leider kopiert er nur die Werte und Formatierungen in die neuen Dateien.
Ich brauche z.B. noch, das die Formeln und auch z.B. ausgeblendete Zeilen mit in die neue Datei übernommen werden. Ist das möglich?
Sub Test()
Dim MyDic As Object, rng As Range, Zelle As Range, ws As Worksheet, wb As Workbook
Application.ScreenUpdating = False
Set MyDic = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
For Each Zelle In rng.Offset(1, 0)
If MyDic(Zelle.Value) = "" And Not IsEmpty(Zelle) Then
MyDic(Zelle.Value) = 1
rng.AutoFilter field:=1, Criteria1:=Zelle
Set wb = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Zelle & ".xlsx", FileFormat:=51
wb.Close False
rng.AutoFilter
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Besten Dank vorab :-)
Viele Grüße
Martin

24
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 16:40:09
Daniel
Hallo Martin,
Das Problem mit den ausgeblendeten Zellen ist leicht gelöst. Lass einfach "SpecialCells(xlCellTypeVisible)" weg, also
.UsedRange.Copy wb.Sheets(1).Cells(1, 1)
Meines Verständnisses nach sollte der Rest des Befehls genau wie normales Copy / Paste funktionieren. Warum dann nur Werte und Formatierungen eingefügt werden, kann ich dir so nicht sagen.
Gruß
Daniel
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 19:20:52
Walter
Danke Daniel für deine schnelle Hilfe, somit ist ein Problem gelöst. Kann sonst noch jemand helfen?
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 21:31:58
onur
Schreib doch einfach mal, was der Code genau tun soll und poste die Datei.
Einen Code zu analysieren, ohne die Datei dazu zu sehen, ist überflüssige Mahrarbeit.
Und da du den Code im Netz gefunden und übernommen hast, ohne ihn wirklich zu verstehen, kann es auch sein, dass der Code auch Sachen macht, die gar nicht nötig wären.
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 22:30:23
Walter
Ok ich habe eine Beispiel Datei erstellt. Ziel ist es das daraus 2 "xls" Dateien werden.
Datei 1 Lieferant "herber.xls" mit nur den herber Daten
Datei 2 Lieferant "herber123.xls" mit nur den herber123 Daten
Ansonsten darf nichts verändert werden. Detailiert: Ersten beiden Zeilen bleiben als Kopf pro Datei bestehen, ausgeblendete Spalten, Formatierungen, Formeln usw. sollen unverändert übernommen werden.
Ich hoffe das hilft soweit, beim nächsten mal gibts direkt ne Beispiel datei ;-)
VG
Martin
Hier die Datei:
https://www.herber.de/bbs/user/130984.xlsm
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 23:48:52
onur

Private Sub Test()
Dim Li, wksq, rng2copy, z, ky, lie
Set Li = CreateObject("Scripting.Dictionary")
Set wksq = ThisWorkbook.ActiveSheet
With wksq
For z = 3 To 10000
lie = .Cells(z, 1).Value
If Not Li.Exists(lie) And lie  "" Then Li.Add lie, lie
Next z
For Each ky In Li.keys
Set rng2copy = .Range(.Cells(1, 1), .Cells(2, 10))
For z = 3 To 10000
lie = .Cells(z, 1).Value
If lie = ky Then
Set rng2copy = Union(rng2copy, Range(Cells(z, 1), Cells(z, 10)))
End If
Next z
rng2copy.Select
Set wb = Workbooks.Add
rng2copy.Copy wb.Sheets(1).Cells(1, 1)
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ky & ".xlsx", FileFormat:=51
wb.Close False
Next
End With
End Sub

Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
18.07.2019 23:52:46
onur
rng2copy.Select kann weg.
AW: Exceldatei splitten inkl. aller Formeln usw.
19.07.2019 09:54:56
Walter
Hallo Onur,
Besten Dank! Es funktioniert, bis auf 2 Kleinigkeiten:
- die ausgeblendete Spalten (G&H) sollen in den neu erstellten Dateien weiterhin ausgeblendet bleiben
- die Spalten breite soll bitte auch so bleiben
Das i-tüpfelchen wäre folgendes:
Die Datei ist mit einem Blattschutz versehen mit folgenden Kriterien (siehe Screenshot)
https://www.herber.de/bbs/user/130988.jpg
Passwort ist - herber
Frage: wäre es möglich das die neu erstellten Dateien auch genau diesen Blattschutz enthalten?
Anbei die Datei:
https://www.herber.de/bbs/user/130989.xlsm
Vielen Dank vorab, hoffe das ich mich irgendwann mal revanchieren kann!
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
21.07.2019 22:56:25
Walter
Onur! Herzlichen Dank! MEGA GUT! Oh man ich will das auch können...
Viele Grüße
Martin
AW: Exceldatei splitten inkl. aller Formeln usw.
22.07.2019 12:02:26
Walter
Hallo Onur, funktioniert leider doch nicht 100%.
Die 1. Datei ist super, aber in der 2. Datei werden keine Formeln mehr hinterlegt :-(
Kannst du mir nchmal kurzfristig helfen?
AW: Exceldatei splitten inkl. aller Formeln usw.
22.07.2019 12:09:39
onur
Kann eigentlich nicht sein, da der Code exakt der Selbe für BEIDE Blätter ist, da Schleife.
Höchstens weil in Originaldatei auch keine Formeln sind.
AW: Exceldatei splitten inkl. aller Formeln usw.
22.07.2019 12:22:00
Walter
Formeln sind vorhanden, werden aber nur für die erste Datei übernommen.
Probier bitte deine Datei aus, die 2. "herber123" Datei hat keine Formeln enthalten.
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
22.07.2019 12:33:39
onur
Wenn ich wieder zu Hause bin ....
AW: Exceldatei splitten inkl. aller Formeln usw.
22.07.2019 13:20:31
Walter
okay, danke schon mal vorab für deine Mühe.
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 08:17:29
Walter
Danke Onur, es funktioniert! Die Datei an der ich das einsetze ist ziemlich groß und durch die Berechnung läuft es ewig. Habe es auch schon mit folgendem probiert:
Sub DeinCode()
Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
'***Deine Anweisungen***
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
Application.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
End Sub
...läuft aber trotzdem solange, wahrscheinlich ist es an der falschen Stelle eingesetzt.
Falls dafür noch eine Lösung hast, wäre es klasse, wenn nicht ist es auch nicht schlimm. Funktioniert ja :-)
Gruß
Martin
Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 09:05:04
Walter
Pro Datei 14 min, Gesamt sind es etwa 200 (ca. 46 Stunden) Wäre toll wenn du mir die Berechnung abschalten könntest...
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 10:17:34
Walter
falls jemand anders helfen kann wäre es auch super :-)
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 10:18:37
onur
Sobald ich ....
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 12:07:06
Walter
ok alles klar
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 15:11:59
Walter
Ich habe nochmal eine bessere Beispieldatei mit deinem Code hochgeladen, da siehst du es besser wie lange es dauert.
https://www.herber.de/bbs/user/131031.xlsm
Gruß
Martin
AW: Exceldatei splitten inkl. aller Formeln usw.
23.07.2019 16:24:45
peterk
Hallo Walter
Probier mal folgenden Code
Sub DateienErstellen2()

    Application.ScreenUpdating = False               'Bildschirmaktualisierung ausschalten 
    Application.Calculation = xlCalculationManual    'automat.Berechnung ausschalten 

    Dim Li As Object
    Dim wksq As Worksheet
    Dim lastRow As Long
    Dim ky As Variant
    Dim wb As Workbook
    Dim z As Long
    Dim lie As String
    
    Set Li = CreateObject("Scripting.Dictionary")
    Set wksq = ThisWorkbook.ActiveSheet

    With wksq
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

        For z = 3 To lastRow
            lie = .Cells(z, 1).Value
            If Not Li.Exists(lie) And lie <> "" Then Li.Add lie, lie
        Next z

        For Each ky In Li.keys
            Debug.Print ky
            .Range("$A$2:$AQ$" & lastRow).AutoFilter Field:=1, Criteria1:="=Supplier", Operator:=xlOr, Criteria2:="=" & ky

            Set wb = Workbooks.Add
            .Range("$A$1:$AQ$" & lastRow).SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(1, 1)

            For z = 1 To 43
                wb.Sheets(1).Columns(z).Hidden = .Columns(z).Hidden
                wb.Sheets(1).Columns(z).ColumnWidth = .Columns(z).ColumnWidth
            Next z

            wb.Sheets(1).Rows("2:2").AutoFilter
            wb.Sheets(1).Protect Password:="dqm", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                                 AllowFormattingCells:=True, AllowFormattingColumns:=True, _
                                 AllowFormattingRows:=True, AllowInsertingColumns:=True, _
                                 AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, _
                                 AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
                                                                                         
            Application.DisplayAlerts = False    'Speichern ohne Rückfrage, ob Überschreiben 
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ky & ".xlsx", FileFormat:=51
            Application.DisplayAlerts = True
            wb.Close False
        Next
    End With

    Application.Calculation = xlCalculationAutomatic    'automat.Berechnung einschalten 
    Application.ScreenUpdating = True                   'Bildschirmaktualisierung einschalten 
End Sub



Anzeige
AW: Exceldatei splitten inkl. aller Formeln usw.
24.07.2019 09:55:13
Walter
BESTEN DANK Onur! Es läuft super :-)
Ich musste lediglich die automatische Berechnung vor dem Speichern der Datei legen, sonst wären alle Dateien ohne auto. Berechnung.
Viele Grüße
Martin

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige