Formel eller VBA hjælp

Skulle nok kunne lade sig gøre. Skal sammentælling ske generelt eller på "anfording" (akkordnr)?

Det lyder godt, jeg skal have mulighed for at ændre akkordnr.

Er det altid 3 akkordnr(A1:A3), der skal specificeres?

Det kan være 1 til 3 akkordnr. der skal specificeres

Ok - er i gang...

VBA-koden indsættes under arket efter BEV-ark
Kan aktiveres ved Alt + F8 / AkkPrMedarbejder markeres / afspil makro - eller forbindes med en knap.
================================================================

Dim BEVark As Worksheet
Dim beregnArk As Worksheet
Const beregnArkNavn = "Ark1"                        '<-- tilpasses

Dim antalRækker As Long
Dim nyRæk As Long, ræk As Byte, akkNr As Long
Public Sub AkkPrMedarbejder()
    Application.ScreenUpdating = False
   
    Set beregnArk = ActiveWorkbook.Sheets(beregnArkNavn)
    Set BEVark = ActiveWorkbook.Sheets("BEV-info")
   
    BEVark.Activate
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    nyRæk = 7
    beregnArk.Activate
   
Rem slet gl. indhold
    Range("A7:B65000").Select
    Selection.ClearContents
   
    For ræk = 1 To 3
        If Range("A" & ræk) <> "" Then
            akkNr = Range("A" & ræk)
            søgAkkordNr akkNr
        End If
    Next ræk
   
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub
Private Sub søgAkkordNr(nr)
Dim ræk
    With BEVark
        For ræk = 2 To antalRækker
            If .Range("B" & ræk) = nr Then
                opdaterBeregnArk .Range("C" & ræk), .Range("D" & ræk)
            End If
        Next ræk
    End With
End Sub
Private Sub opdaterBeregnArk(medNr, timer)
Dim medArbRæk As Long
    medArbRæk = findMedarbRæk(medNr)
    If medArbRæk > 0 Then
        Range("B" & medArbRæk) = Range("B" & medArbRæk) + timer
    Else
        Range("A" & nyRæk) = medNr
        Range("B" & nyRæk) = timer
        nyRæk = nyRæk + 1
    End If
End Sub
Private Function findMedarbRæk(medNr)
    With beregnArk.Range("A7:A" & nyRæk)
        Set c = .Find(medNr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findMedarbRæk = c.Row
        Else
            findMedarbRæk = 0
        End If
    End With
End Function

Hej supertekst

Det virker som det skal i prøvefilen, men når jeg indsætter koden i orignal filen virker det ikke. Der er ialt 4 ark der skal laves beregninger på. Har oploadet en ny fil der ligner orignalen.
Håber du har mod på at lave det om. På forhånd tak

Vender tilbage i morgen, har fyraften.

http://www.gratisupload.dk/download/51388/

OK - jeg skal nok "skære den til"..

Rem Koden indsættes i VBA/ThisWorkbook
Rem ==================================
Rem Version 2
Rem ==========

Dim BEVark As Worksheet

Dim beregnArk As Worksheet
Dim beregnArkNavn As Worksheet

Dim antalRækker As Long
Dim nyRæk As Long, ræk As Byte, akkNr As Long
Public Sub AkkPrMedarbejder()
   
    Application.ScreenUpdating = False
   
    Set beregnArk = ActiveWorkbook.ActiveSheet
    Set BEVark = ActiveWorkbook.Sheets("BEV-info")
   
    BEVark.Activate
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    nyRæk = 7
    beregnArk.Activate
   
Rem slet gl. indhold
    Range("A7:C65000").Select
    Selection.ClearContents
   
    For ræk = 1 To 3
        If Range("A" & ræk) <> "" Then
            akkNr = Range("A" & ræk)
            søgAkkordNr akkNr
        End If
    Next ræk
   
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub
Private Sub søgAkkordNr(nr)
Dim ræk
    With BEVark
        For ræk = 2 To antalRækker
            If .Range("C" & ræk) = nr Then
                opdaterBeregnArk .Range("A" & ræk), .Range("D" & ræk), .Range("F" & ræk)
            End If
        Next ræk
    End With
End Sub
Private Sub opdaterBeregnArk(afdNr, medNr, timer)
Dim medArbRæk As Long
    medArbRæk = findMedarbRæk(medNr)
    If medArbRæk > 0 Then
        Range("C" & medArbRæk) = Range("C" & medArbRæk) + timer
    Else
        Range("A" & nyRæk) = afdNr
        Range("B" & nyRæk) = medNr
        Range("C" & nyRæk) = timer
        nyRæk = nyRæk + 1
    End If
End Sub
Private Function findMedarbRæk(medNr)
    With beregnArk.Range("B7:B" & nyRæk)
        Set c = .Find(medNr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findMedarbRæk = c.Row
        Else
            findMedarbRæk = 0
        End If
    End With
End Function

Har kørt beregningerne for alle 4 bånd - totaler stemmer med BEV.

supertekst, du er en sand troldmand. Mange tak for hjælpen