Saldoopløsning af konti pr. arkfane

Det skulle være mærkeligt, om det ikke kunne lade sig gøre - måske ville en lidt illustration - eller send en model til pb@supertekst-it.dk.

Hvis du omdøber dit dataark til 'Data' så skulle denne virke.
Den tager IKKE række1 med, jeg går ud fra at du har overskrifter.
Række 1 indsættes ved nye ark

Public Sub FlytTilArk()
    Application.ScreenUpdating = False
    Dim Findes As Boolean, I As Long, WS As Worksheet, NewSheet As Worksheet, Sidenavn As String
    For I = 2 To Worksheets("Data").Range("A65536").End(xlUp).Row
        Findes = False
        Sidenavn = Worksheets("Data").Cells(I, 1)
        For Each WS In Worksheets
            If WS.Name = Sidenavn Then
                Findes = True
                Exit For
            End If
        Next WS
        If Findes Then
            Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
        Else
            Set NewSheet = Worksheets.Add
            NewSheet.Name = Sidenavn
            Worksheets("Data").Rows(1).Copy Worksheets(Sidenavn).Range("A1") ' overskrifter på nye ark
            Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
            Set NewSheet = Nothing
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Kabbak > Lige i øjet :o)

Så har du sikkert også en funktion, som formatterer alle arkene pænt :o)

"Så har du sikkert også en funktion, som formatterer alle arkene pænt :o)"
Ved copy burde formatet følge med, eller er det kolonnebredden du mener ??

Kabbak > den formattering jeg ønsker, er lidt mere avanveret, men kan vel reelt indsættes her imellem :

Else
    Set NewSheet = Worksheets.Add
    NewSheet.Name = Sidenavn
    Worksheets("Data").Rows(1).Copy Worksheets(Sidenavn).Range("A1") '
    Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
    Set NewSheet = Nothing
End If

ja det er korrekt, optag en makro med den formattering du vil have, og sæt koden ind.

Else
    Set NewSheet = Worksheets.Add
    NewSheet.Name = Sidenavn
    Worksheets("Data").Rows(1).Copy Worksheets(Sidenavn).Range("A1") '
    Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
Worksheets(Sidenavn).Select
'din kode for formattering
    Set NewSheet = Nothing
End If

Kabbak > Jeg har tillige behov for et samleark, hvor konti grupperes/summeres på de første decimaler ... er du også mand for den ( nyt sprøgsmål oprettes )

Sorry ... Første 4 decimaler

Kabbak > koden virker i og for sig ude efter hensigten .... men er der nogen måde hvorpå man kan "speede" afvikligen op ... lige nu, genererer den vel en arkfane på 1-2 minutter, ... så generering af 100 ark, tager sin tid ...

Andre løsninger ???

Hvad hvis jeg kommer ud over 255 arkfaner ???

Prøv denne, den skulle være ca dobbelt så hurtig.
Det tog 1 min og 56 sek, for at oprette 218 ark og flytte 8893 datarækker.

Vær opmærksom på, at hvis du i koden indsætter formatering af arkene, det sløver.

Public Sub FlytTilArk2()
    Dim Findes As Boolean, I As Long, WS As Worksheet, NewSheet As Worksheet, Sidenavn As String
    Dim RW As Long, Navne As Variant, Start As Date, SH As Integer
    SH = 0
    Application.ScreenUpdating = False
    Start = Now()
    On Error GoTo Fejl
    RW = Worksheets("Data").Range("A65536").End(xlUp).Row
    Navne = Worksheets("Data").Range("A1:A" & RW)
    For I = 2 To RW
        Sidenavn = Navne(I, 1)
Ok:
        Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
    Next
 
    Application.ScreenUpdating = True
      MsgBox "Det tog " & Format(Now() - Start, "nn:ss") & " minutter" & vbCrLf _
    & " for at oprette " & SH & " ark" & vbCrLf _
    & " med " & RW & " datarækker"
    Exit Sub
Fejl:
    Set NewSheet = Worksheets.Add
    NewSheet.Name = Sidenavn
    Worksheets("Data").Rows(1).Copy Worksheets(Sidenavn).Range("A1")    ' overskrifter på nye ark
    Set NewSheet = Nothing
    SH = SH + 1
    Err.Clear
    Resume Ok
End Sub

:o( 2 timer 45 minutter ) for 162 ark ...

Arket som kopieres/hentes fra, indeholder formattering, derfor den lange genereringstid ... jeg vinder vel ikke noget nævneværdigt ved at ophæve formatteringen fra mit grundark, og efterfølgende formattere enkeltarkene til sidst ?

må jeg se din formaterings kode, er formateringen den samme som Dataarket ??

Hej kabbak > jeg tror problemer ligge i, at jeg kopierer fra en SAP-rapport genereret via BEX-Analyzer ... denne indeholder som standard noget speciel formattering, som gør at din programkode aflæses langsomt linie for linie. Jeg har optimeret min efterfølgende formattering, således at jeg har en nogenlunde 50/50 fordeling i procestiden mellem kopiering og formattering, således at procestiden er nede på omkring 2 timer nu, hvilket er absolut acceptabelt, når det sammenholdes med at bestillingen af rapporterne enkeltvis, minimum vil tage dobbelt så lang tid.

Jeg fatter ikke dine tider
Jeg oprettede et tomt ark, med de ønskede formateringer, og tog så fra den.

Jeg har lige testet på 12000 rækker med data i 2 kolonner og 250 forskellige konti.

Det tog 2:56 min for at oprette arkene og kopier data.

I makroen har jeg nu lavet så den gemmer mappen, det er for at frigøre hukommelse.

Derefter køres formateringen, det tog 2 sek. for de 250 ark.


Public Sub FlytTilArk2()
    Dim Findes As Boolean, I As Long, ws As Worksheet, NewSheet As Worksheet, Sidenavn As String
    Dim RW As Long, Navne As Variant, Start As Date, SH As Integer
    SH = 0
    Application.ScreenUpdating = False
    Start = Now()
    On Error GoTo Fejl
    RW = Worksheets("Data").Range("A65536").End(xlUp).Row
    Navne = Worksheets("Data").Range("A1:A" & RW)
    For I = 2 To RW
        Sidenavn = Navne(I, 1)
Ok:
        Worksheets("Data").Rows(I).Copy Worksheets(Sidenavn).Range("A65536").End(xlUp).Offset(1, 0)
    Next

    Application.ScreenUpdating = True
    MsgBox "Det tog " & Format(Now() - Start, "nn:ss") & " minutter" & vbCrLf _
        & " for at oprette " & SH & " ark" & vbCrLf _
        & " med " & RW & " datarækker"
    ActiveWorkbook.Save ' NY gemmer efter at den har oprettet arkene
    Call FormatArk ' kalder formateringen
    Exit Sub
Fejl:
    Set NewSheet = Worksheets.Add
    NewSheet.Name = Sidenavn
    Worksheets("Data").Rows(1).Copy Worksheets(Sidenavn).Range("A1")    ' overskrifter på nye ark
    Set NewSheet = Nothing
    SH = SH + 1
    Err.Clear
    Resume Ok
End Sub

Public Sub FormatArk()
    Dim ws As Worksheet, Start As Date, SH As Integer
    SH = 0
    Start = Now()
    'Denne makro, kræver et ark, med navnet "Format", dette ark skal indeholde alle de formatteringer,
    'som man ønsker i de nyoprettede ark, der skal ikke være værdier i cellerne.
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Data" And ws.Name <> "Format" And ws.Name <> "Stamdata" Then
            Sheets("Format").Cells.Copy
            Sheets(ws.Name).Activate
            Sheets(ws.Name).Cells.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                                              False, Transpose:=False
            Application.CutCopyMode = False
            Range("A1").Select
            SH = SH + 1
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Det tog " & Format(Now() - Start, "nn:ss") & " minutter" & vbCrLf _
        & " for at Formatere " & SH & " ark"

End Sub

Jeg har testet kabbak's løsning og den virker fint for mig.

Hvis hastigheden på den nye kode stadig er for langsom, så er her en anden approach, der ikke er bedre men anderledes og kan måske virke bedre.
I Begge inputbokse skal du pege på A1

Option Base 1
Option Explicit

Sub FilterAndCopy()
       
    Dim Uniq_Matrix As New Collection
    Dim TempMatrix, Item
    Dim StartSheet As Worksheet
    Dim rngStart As Range, rngIndexCol As Range
    Dim I As Long
    Dim iCounter As Integer, iUniqTotal As Integer, iFilterCol As Integer
   
    Set StartSheet = ActiveSheet
    With Application
      .DisplayStatusBar = True
        Set rngStart = .InputBox("Angiv start af dataområde", "Dataområde", Type:=8)
        Set rngIndexCol = .InputBox("Angiv indexkolonnen (kolonnen til nye ark)", "Indexering", Type:=8)
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    '***fyld alle data i kol A over i et midlertidig array
    With rngIndexCol
        TempMatrix = Range(Cells(rngStart.Row, .Column), Cells(65536, .Column).End(xlUp).Address)
        iFilterCol = .Column - rngStart.Column + 1
    End With
    '***træk de unikke items ud i en collection
    On Error Resume Next
    For I = 2 To UBound(TempMatrix)
        Uniq_Matrix.Add TempMatrix(I, 1), CStr(TempMatrix(I, 1))
    Next I
    On Error GoTo 0
    '***Frigør TempMatrix
    Set TempMatrix = Nothing
    iUniqTotal = Uniq_Matrix.Count
    '***med alle unikke items, autofilter og kopier til nyt ark
    For Each Item In Uniq_Matrix
        With rngStart.Cells(1, 1)
            .AutoFilter Field:=iFilterCol, Criteria1:=Item
            .CurrentRegion.Copy
        End With
        Sheets.Add
        ActiveSheet.Name = Item
        ActiveSheet.Paste
        'Range("A1").PasteSpecial (xlPasteValues)
        iCounter = iCounter + 1
        Application.StatusBar = iCounter & "  af  " & iUniqTotal & " kopieret"
    Next
   
    rngStart.AutoFilter
    With Application
      .CutCopyMode = False
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
      .StatusBar = False
    End With
    Set Uniq_Matrix = Nothing
End Sub

Jaa bak, den gjorde det på 21 sek., det der tog 2:56 min. for min, jeg havde tænkt, i den retning, men manglede ekspertisen til at lave det. ;-))

Så må vi jo håbe at det ikke bliver til 21 min. i jensens ark :-)

Jeg er åben overfor alt ... sender gerne modellen med testdata, hvis I har mulighed for at kigge på den :o)

Iøvrigt bliver procestiden langsommere jo flere ark den skal generere :

  5 arkfaner genereres på 26 sek      = 5 sek pr stk
  160 arkfaner genereres på 2 timer    = 45 sek pr stk

excel snabela tbdl.dk

Hvilken xl-version bruger du, og hvor stor en maskine har du (ram, mhz) ?

Hej bak > efter implementering af din kode ( har først lige testet den ), er procestiden nede på 8 minutter for 162 ark ... så der er vist ingen grund til at spilde mere tid på den :o) .... jeg er dybt taknemmelig jeres hjælp

jeg kunne stadig godt tænke mig at vide hvilken xl-version du bruger :-)

Benytter Office XP-Pro ( Excel 2003 )

Processor = x86 Family 15 Model 2 3065 MHz
RAM = 1 Gb

jeg vil også gerne se et testark
kabbak snabela email dot dk

Med de specifikationer burde du ikke have problemer. xl2003 kan bruge alt dit ram, i modsætning til nogle af de tidligere versioner.

Jeg synes ikke I behøver at ofte mere tid på opgaven. Jeg er ovenud tilfreds :o)

Det er ren interesse, fordi det er en udfordring, at finde ud af hvorfor den er langsom ved dig.

Det er forresten ,ikke sådan at du har en antivirus der tjekker ændringer i regnearket, det kan sløve gevaldig.

enig med kabbak, ren udfordring, send :-)

Øjeblik, jeg skal lige have den renset for følsomme data

kabbak > din emailadresse afvises

jeg huskede forkert, da jeg har flere

kabbak snabela Tiscali dot dk

prøv at teste denne

Option Explicit

Public Sub Flytte_Data3()
    Dim TempArray As Variant, I As Long, Start As Date, SH As Integer, NewSheet As Worksheet
    Dim Total As Long, COL As Long, X As Long
    Dim Tempvar As Variant, Overskrift As Variant
    SH = 0
    Start = Now()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    TempArray = Sheets("Data").Range("A1").CurrentRegion    'Læser data

    Set NewSheet = Worksheets.Add    ' opretter nyt ark
    NewSheet.Name = "Temp"    ' ny arks navn
    Sheets("Temp").Range(Cells(1, 1), Cells(UBound(TempArray, 1), UBound(TempArray, 2))) = TempArray    'gemmer på anyt ark
    Range("A1").Select    ' sorterer på kolonne 1
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    TempArray = Sheets("Temp").Range("A1").CurrentRegion    ' læser de sorterede ind igen
    Total = UBound(TempArray, 1)    ' antal rækker
    COL = UBound(TempArray, 2)  ' antal kolonner
    Overskrift = Sheets("Temp").Range(Cells(1, 1), Cells(1, COL))

    X = 2
    On Error Resume Next
    For I = 2 To Total    ' starter ved række 2
        If TempArray(I, 1) <> TempArray(I + 1, 1) Then
            Worksheets("Temp").Activate
            Tempvar = Worksheets("Temp").Range(Cells(X, 1), Cells(I, COL))
            Set NewSheet = Worksheets.Add
            NewSheet.Name = Str(TempArray(I, 1))
            Range(Cells(1, 1), Cells(1, COL)) = Overskrift
            Range(Cells(2, 1), Cells(UBound(Tempvar, 1) + 1, COL)) = Tempvar
            X = I + 1
            SH = SH + 1
            Application.StatusBar = " Række " & I & "  af  " & Total - 1 & " kopieret"
        End If

    Next
    Application.DisplayAlerts = False
    Sheets("Temp").Delete    ' sletter det midlertidige ark
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Det tog " & Format(Now() - Start, "nn:ss") & " minutter" & vbCrLf _
        & " for at oprette " & SH & " ark" & vbCrLf _
        & " med " & Total - 1 & " datarækker"
    ActiveWorkbook.Save    ' NY gemmer efter at den har oprettet arkene
    Call FormatArk    ' kalder formateringen
    Application.Calculation = xlCalculationAutomatic
End Sub
Public Sub FormatArk()
    Dim ws As Worksheet, Start As Date, SH As Integer
    SH = 0
    Start = Now()
    'Denne makro, kræver et ark, med navnet "Format", dette ark skal indeholde alle de formatteringer,
    'som man ønsker i de nyoprettede ark, der skal ikke være værdier i cellerne.
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Data" And ws.Name <> "Format" And ws.Name <> "Stamdata" Then
            Sheets("Format").Cells.Copy
            Sheets(ws.Name).Activate
            Sheets(ws.Name).Cells.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                                              False, Transpose:=False
            Application.CutCopyMode = False
            Range("A1").Select
            SH = SH + 1
        End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Det tog " & Format(Now() - Start, "nn:ss") & " minutter" & vbCrLf _
        & " for at Formatere " & SH & " ark"

End Sub

Hej Venner ... jeg er imponeret over jeres ildhu og arbejdsiver ... problemet ligger i den server jeg henter data fra ( citrix ), så der er vist ikke meget at komme efter mere :o)