Aus XLSM pro Gruppe neue txt-Dateien erstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter,
probier mal diesen Code.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub K_Gruppen()
Dim rngAll As Range, objWB As Workbook
Dim varCrit As Variant
Dim lngI As Long
Dim strFile As String, strPath As String
Dim CalculationMode As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

strPath = "E:\Forum\Test2"  'Verzeichnis - Anpassen!

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

With Sheets("Umsatzaufstellung")
  Set rngAll = .Range("A3").CurrentRegion
End With

Set rngAll = rngAll.Offset(2, 0).Resize(rngAll.Rows.Count - 2, rngAll.Columns.Count)

With rngAll
  varCrit = .Columns(1).Offset(1, 0)
  varCrit = toArrayUnique(varCrit)
  If IsArray(varCrit) Then
    For lngI = 0 To UBound(varCrit)
      .AutoFilter Field:=1, Criteria1:=varCrit(lngI)
      strFile = varCrit(lngI) & Format(Date, "_yyyyMMDD") & ".txt"
      Set objWB = Workbooks.Add(xlWBATWorksheet)
      .Copy objWB.Sheets(1).Range("A1")
      objWB.Sheets(1).Range("A:B").Delete
      objWB.Sheets(1).Cells.Font.Name = "Arial"
      objWB.Sheets(1).Cells.Font.Size = 8
      objWB.Sheets(1).Range("A:B").Delete
      objWB.SaveAs Filename:=strPath & strFile, FileFormat:=xlText, local:=True, CreateBackup:=False
      objWB.Close False
      Set objWB = Nothing
    Next
  End If
  .AutoFilter
End With

Sheets("Umsatzaufstellung").Range("A1").Select


ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'nn'" & vbLf & String(25, "") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, 81968, "VBA - Fehler in Prozedur - K_Gruppen", .HelpFile, .HelpContext
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

Set rngAll = Nothing
End Sub

Private Function toArrayUnique(Field As Variant, Optional Sort As Integer = 1) As Variant
'Sort  unsortiert = 0, sortiert A-Z = 1, sortiert Z-A = -1
Dim objArrayList As Object
Dim lngR As Long, lngC As Long

On Error GoTo ErrExit

Set objArrayList = CreateObject("System.Collections.Arraylist")

With objArrayList
  For lngR = LBound(Field, 1) To UBound(Field, 1)
    For lngC = LBound(Field, 2) To UBound(Field, 2)
      If Not .Contains(Trim(Field(lngR, lngC))) Then
        If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
      End If
    Next
  Next
  If Sort <> 0 Then .Sort
  If Sort < 0 Then .Reverse
  toArrayUnique = .toArray
End With

Exit Function
ErrExit:
toArrayUnique = -1
End Function

Gruß Sepp

Sub test() Dim Zelle1 As Range, zelle2 As Range With Sheets("Umsatzaufstellung") '--- nach Spalte 1 sortieren, kann entfallen wenn gegeben With .Range(.Cells(4, 1), .Cells(3, 1).End(xlDown)).EntireRow .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo End With Workbooks.Add xlWBATWorksheet '--- Überschrift kopieren .Range("A1:C3").Copy Destination:=ActiveSheet.Cells(1, 1) '--- Gruppen kopieren und als text speichern Set zelle2 = .Range("A3") Do Set Zelle1 = zelle2.Offset(1, 0) If Zelle1.Value = "" Then Exit Do Set zelle2 = .Columns(1).Find(what:=Zelle1.Value, lookat:=xlWhole, searchdirection:= _ xlPrevious) ActiveSheet.UsedRange.Offset(3, 0).ClearContents Range(Zelle1, zelle2).Resize(, 3).Copy Destination:=ActiveSheet.Cells(4, 1) ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Zelle1.Value, FileFormat:=xlText Loop ActiveWorkbook.Close False End With End Sub

Beliebteste Forumthreads (12 Monate)

Aus XLSM pro Gruppe neue txt-Dateien erstellen

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Aus XLSM pro Gruppe neue txt-Dateien erstellen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread