Sammenkædning og summering af data

Hvis muligt må gerne sende en kopi af filen - "det letter ekspeditionen" - så skal jeg gøre et forsøg...
(pb@supertekst-it.dk)

Er sendt.

Rem Version 1
Rem =========
Const optællingsArk = "DATAARK Pareto"
Const dataArk = "DATAARK"

Dim antalRæk, fRække, dArk As Worksheet, optælArk As Worksheet
Sub FejlOptælling()
Dim pNavn, pDato As Date, pMisP, insFail, visionFail, fAtt, fFail

Rem def. ark
    Set dArk = ActiveWorkbook.Sheets(dataArk)
    Set optælArk = ActiveWorkbook.Sheets(optællingsArk)
   
Rem Slet gl. data på optællingsark
    optælArk.Activate
    ActiveSheet.Rows("2:65000").Select
    Selection.Delete Shift:=xlUp

Rem dataArk aktiveres
    dArk.Activate
   
Rem Find antal rækker i arket
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
Rem startRække i optællingsarket
    fRække = 2
   
    Application.ScreenUpdating = False
   
Rem Traverser Arket
    For ræk = 2 To antalRæk
        pNavn = Cells(ræk, 1)                                  'A kol

Rem kun beh. hvis pNavn udfyldt
        If pNavn <> "" Then
            pDato = Format(Cells(ræk, 2), "dd-mm-yyyy")            'B -
            pMisP = Cells(ræk, 13)                                  'M -
            insFail = Cells(ræk, 15)                                'O -
            visionFail = Cells(ræk, 16)                            'P -
            fAtt = Cells(ræk, 17)                                  'Q -
            fFail = Cells(ræk, 18)                                  'R -
           
            optælFejl pNavn, pDato, pMisP, insFail, visionFail, fAtt, fFail
        End If
    Next ræk

    Application.ScreenUpdating = True
   
Rem Vis optællingsArk
    optælArk.Activate
    ActiveSheet.Cells(1, 1).Select
   
    MsgBox ("Optælling afsluttet")
End Sub
Private Sub optælFejl(pNavn, pDato, pMisP, insFail, visionFail, fAtt, fFail)
Dim pRæk
    pRæk = findesPnavnPdato(pNavn, pDato)
   
    If pRæk = 0 Then
        pRæk = fRække
        fRække = fRække + 1
    End If
   
    With optælArk
        .Cells(pRæk, 1) = pNavn
        .Cells(pRæk, 2) = pDato
        .Cells(pRæk, 3) = .Cells(pRæk, 3) + pMisP
        .Cells(pRæk, 4) = .Cells(pRæk, 4) + insFail
        .Cells(pRæk, 5) = .Cells(pRæk, 5) + visionFail
        .Cells(pRæk, 6) = .Cells(pRæk, 6) + fAtt
        .Cells(pRæk, 7) = .Cells(pRæk, 7) + fFail
    End With
End Sub
Private Function findesPnavnPdato(pNavn, pDato)
    With optælArk
        For ræk = 2 To fRække
            If LCase(.Cells(ræk, 1)) = LCase(pNavn) And .Cells(ræk, 2) = pDato Then
                findesPnavnPdato = ræk
                Exit Function
            End If
        Next
    End With
    findesPnavnPdato = 0
End Function