sub split
12.06.2019 14:22:11
cbds
habe ein Problem mit meinem
Sub splitten-Makro. Egal bei welcher Datei läuft es nicht mehr durch bzw. startet erst gar _
nicht. Hatte bisher noch nie Probleme damit. Zu kopierende Zellen und Split-Krieterium _
angepasst und das Teil rannte problemlos durch. Hab ich irgnedwo einen Fehler oder muss ich _
bzgl. Excel 2010 etwas anpassen?
Basis Win7 / Excel 2010 deutsche Einstellung.
Anbei das entsprechende Makro:
Sub splitten()
Dim wbMappe As Workbook, _
wbMappeNeu As Workbook, _
lngZeile As Long, lngZeile1 As Long, _
strPfad As String, lngFileFormat As Long, StatusCalc As Long
'Objektvariablen für die involverten Tabellenblätter
Dim wks_Q As Worksheet, wks_Muster As Worksheet, wks_Z As Worksheet
Dim varWert As Variant
'Pfad festlegen (mit "\")
strPfad = "C:\XXX\Listenname_
lngFileFormat = ActiveWorkbook.FileFormat 'Dateiformat der aktuellen Mappe merken
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Erstmal alles in eine neue Mappe temporäre schaufeln
ActiveSheet.Copy
Set wbMappe = ActiveWorkbook
Set wks_Q = wbMappe.Worksheets(1) 'Tabellenblatt mit den Quelldaten
'Leeres Mustertabellenblatt erstellen
wks_Q.Copy After:=wks_Q
Set wks_Muster = ActiveSheet
'in der Originaldatei alles löschen bis auf die Zeilen 1 bis 13
wks_Muster.UsedRange.Offset(13, 0).EntireRow.Delete
wks_Muster.Name = "Muster"
With wks_Q
lngZeile1 = 14 'Startzeile für kopieren setzen
varWert = .Cells(lngZeile1, 35).Value 'Vergleichswert in Spalte AI (= 35.Spalte)
For lngZeile = 14 To .Cells(.Rows.Count, 1).End(xlUp).Row + 1 '+ 1 = 1. leere Zeile
If varWert .Cells(lngZeile, 35).Value Then
Application.StatusBar = "Bearbeite Zeile " & lngZeile & " - Wert: " & varWert
'Mustertabellenblatt und Daten kopieren in neue Arbeitsmappe
wks_Muster.Copy
Set wbMappeNeu = ActiveWorkbook
Set wks_Z = wbMappeNeu.Worksheets(1)
wks_Z.Name = CStr(varWert)
.Range(.Cells(lngZeile1, 1), .Cells(lngZeile - 1, 1)).EntireRow.Copy Destination:= _
wks_Z.Cells(14, 1)
Application.DisplayAlerts = False 'gleiche Dateinamen werden überschrieben - _
Testzeile
wbMappeNeu.SaveAs Filename:=strPfad & CStr(varWert), FileFormat:=lngFileFormat
Application.DisplayAlerts = True ' - Testzeile
wbMappeNeu.Close
Set wbMappeNeu = Nothing
Set wks_Z = Nothing
lngZeile1 = lngZeile 'neue Startzeile für Kopieren setzen
varWert = .Cells(lngZeile1, 35).Value 'neuer Vergleichswert in Spalte AI
End If
Next lngZeile
End With 'wks_Q
'temporäre Mappe ohne speichern schliessen
wbMappe.Close savechanges:=False
'Makrobremsen zurücksetzen
With Application
.StatusBar = False
.Calculation = StatusCalc
.ScreenUpdating = True
.EnableEvents = True
End With
'Objektvariablen aufräumen
Set wbMappe = Nothing
Set wks_Q = Nothing
Set wks_Muster = Nothing
End Sub