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
