VBA - Liste auf mehrere Blätter verteilen

Sub GAForm() Rows(1).ClearContents With Cells(3, 2).CurrentRegion With .Offset(-1, 0).Resize(.Rows.Count + 2) .Cells(1, 1).Value = 1 .Cells(1, 1).Copy .SpecialCells(xlCellTypeConstants, 2).PasteSpecial xlPasteValues, operation:=xlMultiply .Rows(1).Value = Array("Datum", "Code", "Wert") .Columns(1).NumberFormat = "DD.MM.YYYY hh:mm" .Cells(.Rows.Count, 1).Value = "Summe" .Cells(.Rows.Count, 3).FormulaR1C1 = "=Sum(R[-" & .Rows.Count - 2 & "]C:R[-1]C)" .BorderAround Weight:=xlThin .Borders(xlInsideHorizontal).Weight = xlThin .Borders(xlInsideVertical).Weight = xlThin .Rows(1).Font.Bold = True .Rows(.Rows.Count).Font.Bold = True .Cut Destination:=Cells(5, 1) Columns("A:A").EntireColumn.AutoFit ActiveWindow.DisplayGridlines = False Columns("B:B").EntireColumn.AutoFit Range("C6").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Selection.NumberFormat = "#,##0.00 $" Rows("4:4").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove End With End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
kannst mal so testen.
Deinen Code habe ich nicht eingebaut, dass kannst mal selbst versuchen ;-)
Evtl. solltest Du die Datei als .xlsm abspeichern, .xlsx kann kein VBA!

Option Explicit

Sub Aufteilen()
Dim ArWerte(), oDic As Object, rng As Range, rngFilter As Range
Dim n&

Events_ False

With Tabelle1 'Datentabelle 
    Set rng = .UsedRange.Resize(, .UsedRange.Columns.Count + 1)
    ArWerte = .Range("D2", .Cells(.Rows.Count, 4).End(xlUp))
    Set oDic = CreateObject("Scripting.Dictionary")
    For n = 1 To Ubound(ArWerte)
        If IsNumeric(ArWerte(n, 1)) Then
            oDic(ArWerte(n, 1)) = 0
        Else
            oDic(""" & ArWerte(n, 1) & """) = 0
        End If
    Next n
    ArWerte = oDic.keys
    QuickSort ArWerte, Lbound(ArWerte), Ubound(ArWerte)
    With ThisWorkbook
        Set rngFilter = rng.Cells(2, rng.Columns.Count)
        rngFilter.NumberFormat = "General"
        For n = Lbound(ArWerte) To Ubound(ArWerte)
            CheckTab_And_Kill ArWerte(n)
            With Sheets.Add(After:=.Sheets(.Sheets.Count), Type:=xlWorksheet)
                .Name = ArWerte(n)
                rngFilter.Cells(2, 1).FormulaR1C1 = "=RC4=" & ArWerte(n)
                rngFilter.Calculate
                rng.AdvancedFilter xlFilterCopy, rngFilter, .Cells(1, 1)
                .UsedRange.EntireColumn.AutoFit
            End With
            rngFilter.Clear
        Next n
    End With
End With
Events_ True
End Sub

Sub CheckTab_And_Kill(ByVal strTabName$)
Dim oSH As Object
On Error Resume Next
Set oSH = ThisWorkbook.Sheets(strTabName)
If Not oSH Is Nothing Then oSH.Delete
End Sub

Sub Events_(booSchalter As Boolean)
With Application
    .EnableEvents = booSchalter
    .DisplayAlerts = booSchalter
    .ScreenUpdating = booSchalter
End With
End Sub

Sub QuickSort(ByRef sArray As Variant, ByVal MinElem As Long, MaxElem As Long)
Dim Mitte As Long
Dim vDummy As Variant
Dim i As Long, j As Long
    If MinElem > MaxElem Then
        Exit Sub
    End If

    Mitte = (MinElem + MaxElem) \ 2

    i = MinElem
    j = MaxElem
    Do
        Do While sArray(i) < sArray(Mitte)
            i = i + 1
        Loop
        Do While sArray(j) > sArray(Mitte)
            j = j - 1
        Loop
        If i <= j Then
            vDummy = sArray(j)
            sArray(j) = sArray(i)
            sArray(i) = vDummy
            i = i + 1
            j = j - 1
        End If
    Loop Until i > j
    QuickSort sArray, MinElem, j
    QuickSort sArray, i, MaxElem
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

VBA - Liste auf mehrere Blätter verteilen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread