Modulkode : Summering for udvalgte kontonumre

Måske - men en lille ilustration(før/efter) ville nok lette forståelsen.

Jeg kan sende et regnearkseksempel ... har du en mail ?

Supertekst > har du opgivet ?

Nej da - pb@supertekst-it.dk

Løsning godkendt ... Imponerende performance ( testet med 25.000 poster )

Læg venligst svar :-)

Tak for det....

Her er koden:
Dim rækFør, rækEfter, flagJ As Boolean
Dim ktoGrp, ktoNr, bDato As Date, md, bNr, delRgn, beskriv, debet As Variant, kredit As Variant, sum
Sub modulKode()
    ActiveWorkbook.Sheets(1).Activate
   
    rækFør = 2
    rækEfter = 1
   
    With Worksheet
        overførUændret 1, rækEfter                        'overskrifter
       
        For Ræk = 2 To 65000
            If Cells(Ræk, 1) <> "" Then
                If Ræk = 2 Then                            '1. detail-række
                    nyeBrudFelter Ræk
                    flagJ = False
                End If

                If Cells(Ræk, 9) = "N" And flagJ = False Then
                    overførUændret Ræk, rækEfter
                    flagJ = False
                Else
                    If flagJ = False Then
                        nyeBrudFelter Ræk
                        flagJ = True
                    Else
Rem brud på kontonr - eller måned
                        If Cells(Ræk, 2) <> ktoNr Or Month(Cells(Ræk, 3)) <> md Then
                            overførSum rækEfter
                            nyeBrudFelter Ræk
                           
Rem hvis aktuelle=N - så overførmed det samme
                            If flagJ = True And Cells(Ræk, 9) = "N" Then
                                overførUændret Ræk, rækEfter
                                flagJ = False
                            End If
                        Else
Rem hvis ikke brud - så optælling
                            If Cells(Ræk, 7) <> "" Then
                                debet = debet + Cells(Ræk, 7)
                            End If
                           
                            If Cells(Ræk, 8) <> "" Then
                                kredit = kredit + Cells(Ræk, 8)
                            End If
                        End If
                    End If
                End If
            End If
        Next Ræk

Rem Overfør evt. sidste række
        If flagJ = True Then
            overførSum rækEfter
        End If
    End With
   
    Columns.AutoFit
    MsgBox ("modulKode afsluttet")
End Sub
Private Sub nyeBrudFelter(Ræk)
    debet = 0
    kredit = 0
   
    With ActiveWorkbook.Sheets(1)
        ktoGrp = .Cells(Ræk, 1)
        ktoNr = .Cells(Ræk, 2)
        bDato = .Cells(Ræk, 3)
        md = Month(bDato)
        bNr = .Cells(Ræk, 4)
        delRgn = .Cells(Ræk, 5)
        beskriv = .Cells(Ræk, 6)
       
        If .Cells(Ræk, 7) <> "" Then
            debet = .Cells(Ræk, 7)
        End If
       
        If .Cells(Ræk, 8) <> "" Then
            kredit = .Cells(Ræk, 8)
        End If
       
        sum = .Cells(Ræk, 9)
    End With
End Sub
Private Sub overførUændret(fRæk, tRæk)
    With ActiveWorkbook.Sheets(2)
        For k = 1 To 9
            .Cells(tRæk, k) = Cells(fRæk, k)
        Next k
        .Cells(tRæk, 3).NumberFormat = "m/d/yyyy"
       
        If .Cells(tRæk, 7) <> "" Then
            .Cells(tRæk, 7).NumberFormat = "#,##0.00"
        End If
       
        If .Cells(tRæk, 8) <> "" Then
            .Cells(tRæk, 8).NumberFormat = "#,##0.00"
        End If
    End With
   
    rækEfter = rækEfter + 1
End Sub
Private Sub overførSum(Ræk)
    With ActiveWorkbook.Sheets(2)
        .Cells(Ræk, 1) = ktoGrp
        .Cells(Ræk, 2) = ktoNr
Rem bilagsdato
        .Cells(Ræk, 3) = bDato
        .Cells(Ræk, 3).NumberFormat = "mm/yyyy"
Rem bilagsnr
        .Cells(Ræk, 4) = ""
        .Cells(Ræk, 5) = delRgn
Rem beskrivelse
        .Cells(Ræk, 6) = "SUM FRA NAVISION"
        .Cells(Ræk, 7) = debet
        .Cells(Ræk, 7).NumberFormat = "#,##0.00"

        .Cells(Ræk, 8) = kredit
        .Cells(Ræk, 8).NumberFormat = "#,##0.00"
       
        .Cells(Ræk, 9) = sum
    End With
    rækEfter = rækEfter + 1
End Sub

Super god og professionel løsning ...