Datei teilen

Hallo zusammen,
ich bin auf der Suche nach einer Lösung für eine Problemstellung, die meine bescheidenen VBA-Kenntnisse leider übersteigt.
Eine xls-Datei mit einem Tabellenblatt soll in mehrere xls-Dateien aufgeteilt werden. Dabei sollen immer die Zeilen zu einer neuen Datei zusammengefasst werden, die in Spalte „F“ den gleichen Wert enthalten. In allen Dateien sollte natürlich die Überschriftenzeile erhalten bleiben. Die neu erstellten Dateien sollten als Namen jeweils den Wert der Spalte „F“ und den Zusatz „Vorgangsliste“ tragen (Beispiel: 56 Vorgangsliste) und im Ordner C:\Verwaltung\nach Betriebsteams gespeichert werden. Um es kurz zu formulieren: Aus einer Datei sollen in dem Beispiel neun Dateien werden (Ausgangsdatei + acht neue).
Hat jemand `ne Lösung für diese Nuss? Ich bin für jede Hilfe dankbar.
Gruß
Matthias
https://www.herber.de/bbs/user/50420.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Datei teilen

04.03.2008 11:13:03

haw

AW: Datei teilen

04.03.2008 11:56:00

Werner

AW: Datei teilen

04.03.2008 12:00:00

Erich

AW: Datei teilen

04.03.2008 11:57:00

Erich

AW: Datei teilen

04.03.2008 13:38:56

Werner

AW: Datei teilen

04.03.2008 15:30:39

Erich

AW: Datei teilen

04.03.2008 16:17:00

Werner

Hallo Matthias,
eine ungetestetes Beispiel:


Sub Aufteilen()
Dim wsV As Worksheet, lz%, i%, T%, efz&, Datei$
Application.ScreenUpdating = False
Set wsV = ThisWorkbook.Worksheets("Vorgänge")
lz = wsV.Cells(Rows.Count, 1).End(xlUp).Row
wsV.Range("A1:H" & lz).Sort Key1:=wsV.Range("F2"), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 2 To lz
T = wsV.Cells(i, 6).Value
Datei = T & " Vorgangsliste.xls"
If T  wsV.Cells(i - 1, 6).Value Then
On Error Resume Next
wb.Close True
On Error GoTo 0
Workbooks.Add
Set wb = ActiveWorkbook
Set ws = ActiveSheet
wsV.Rows("1:2").Copy ws.Range("A1")
ws.Range("A1:H1").EntireColumn.AutoFit
Application.StatusBar = Datei & " wird gespeichert ..."
wb.SaveAs Filename:="C:\Verwaltung\nach Betriebsteams\" & Datei
Else
efz = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsV.Rows(i).Copy ws.Cells(efz, 1)
End If
Next i
On Error Resume Next
wb.Close True
On Error GoTo 0
wsV.Range("A1:H42").Sort Key1:=wsV.Range("F11"), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
wsV.Range("A1:H" & lz).Sort Key1:=wsV.Range("A2"), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Application.ScreenUpdating = True
End Sub

Gruß
Heinz

Option Explicit Sub Aufteilen() Dim wksT As Worksheet, varF, lngVon As Long, zz As Long, intC As Integer Application.ScreenUpdating = False Sheets("Vorgänge").Copy Set wksT = ActiveSheet wksT.UsedRange.Sort Key1:=Range("F2"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom lngVon = 2 varF = Cells(2, 6) zz = 2 With wksT While Not IsEmpty(.Cells(zz + 1, 6)) While varF = .Cells(zz + 1, 6) zz = zz + 1 Wend Workbooks.Add xlWBATWorksheet .Rows(1).Copy Cells(1, 1) .Range(.Rows(lngVon), .Rows(zz)).Copy Cells(2, 1) For intC = 1 To 8 Columns(intC).ColumnWidth = wksT.Columns(intC).ColumnWidth Next intC Cells(2, 1).Select ActiveWindow.FreezePanes = True ActiveWorkbook.SaveAs "C:\Verwaltung\" & varF & " Vorgangsliste.xls" ActiveWorkbook.Close zz = zz + 1 lngVon = zz varF = .Cells(zz, 6) Wend wksT.Parent.Close False End With Application.ScreenUpdating = True End Sub

Option Explicit Sub Aufteilen() Dim wksT As Worksheet, varF, lngVon As Long, zz As Long, intC As Integer Dim intT As Integer Const strSpalte As String = "F" Const strVerz As String = "C:\Verwaltung\" ' mit \" am Ende intT = Columns(strSpalte).Column Application.ScreenUpdating = False ActiveSheet.Copy ' das aktive Blatt wird verwendet Set wksT = ActiveSheet wksT.UsedRange.Sort Key1:=Cells(2, intT), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom lngVon = 2 varF = Cells(2, intT) zz = 2 With wksT While Not IsEmpty(.Cells(zz + 1, intT)) While varF = .Cells(zz + 1, intT) zz = zz + 1 Wend Workbooks.Add xlWBATWorksheet .Rows(1).Copy Cells(1, 1) .Range(.Rows(lngVon), .Rows(zz)).Copy Cells(2, 1) For intC = 1 To 8 Columns(intC).ColumnWidth = wksT.Columns(intC).ColumnWidth Next intC Cells(2, 1).Select ActiveWindow.FreezePanes = True ActiveWorkbook.SaveAs strVerz & varF & " Vorgangsliste.xls" ActiveWorkbook.Close zz = zz + 1 lngVon = zz varF = .Cells(zz, intT) Wend wksT.Parent.Close False End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread