AW: Loop um Datei zu zerstückeln und in neue Datei
17.01.2017 11:16:38
rico003
Danke für die rasche Antwort!
Ich habe jetzt die Excel Datei auch hochgeladen.
Zum Code von mir:
Option Explicit
Sub Umkopieren(ByVal strWhat As String, ByVal wsSrc As Worksheet, lngZeilen As Long, ByVal _
wsDst As Worksheet)
Dim i As Long, j As Long
With wsSrc
.Rows(1).Copy wsDst.Rows(1)
j = 2
For i = 2 To lngZeilen
If .Cells(i, 1).Value = strWhat Then
.Rows(i).Copy wsDst.Rows(j)
'****Zellenbreite dynamisch anpassen****
Selection.Columns.AutoFit
ActiveSheet.UsedRange.Columns.AutoFit
j = j + 1
End If
Next
End With
End Sub
Sub a()
'*****Variabeln Erzeugen*****
Dim wsSrc As Worksheet, wsDst As Worksheet, strKey As String, dic As Object, lngZeilen As _
Long
Dim ar As Variant, i As Long
Dim DateiName As String
Dim pfad As String
'****Dateinamen in Variable Speichern****
DateiName = ActiveWorkbook.Name
'****Objekte Erzeugen****
Set dic = CreateObject("scripting.dictionary")
Set wsSrc = ActiveSheet
'****Speichern Unter Dialogfenster erzeugen und Eingabe in Variable speichern und wieder leeren* _
pfad = Application.Dialogs(xlDialogSaveAs).Show
pfad = Empty
'****Zellenlänge und Start Erzeugen****
With wsSrc
lngZeilen = .UsedRange.Row + .UsedRange.Rows.Count - 1
ar = .Range("A1").Resize(lngZeilen)
End With
'****Schleife zum zählen der Buchstaben in einer Zelle****
For i = 2 To lngZeilen
strKey = Trim(ar(i, 1))
If strKey "" Then
If Not dic.exists(strKey) Then
dic.Add strKey, 1
'****Neue Arbeitsmappe erstellen****
Workbooks.Add
'****Variabeln in anderen Unterprogramm Ãbertragen zum Umkopieren****
Umkopieren strKey, wsSrc, lngZeilen, ActiveSheet
'****Speichern der neuen Arbeitsmappe***
ActiveWorkbook.SaveAs pfad & DateiName & "_" & strKey & " " & Date & ".xlsx"
ActiveWorkbook.Close False
End If
End If
Next
dic.RemoveAll
Set dic = Nothing
End Sub
Ich brauche es in horizontale Ausführung und das schaffe ich grad nicht.
Hier nochmal der Link:
https://drive.google.com/drive/folders/0B4dQxSueSpqTdkM1blZIRzJZMmc
Vielen Dank vorab.