fordeling af km

Måske kunne VBA gøre processen mere automatisk - men det kræver nok lidt mere indsigt i formål m.v.

Jeg forstår ikke dit spørgsmål, hvad har du brug for at oplysninger? :-)

Til dit spørgsmål: "Giver det mening?" - nej

hhmm - ok, hvordan får jeg så lettest gjort et excel ark tilgængelig for dig, så du kan se præcist hvad jeg sidder med?

Du er velkommen til at sende det - @-adresse under min profil.

vi prøver med dropbox

https://dl.dropbox.com/u/90443028/Eksempel.xls

jeg har en rutepris i toppen.
Og så regner jeg ud hvor mange km der er på ruten
og kommer derfra frem til hvad km prisen er.
Så skal jeg fordele km ud på hver person - og så regne ud hvad deres totalpris er.

hvide felter er afhentning - grå er afsætning.
Når den sidste person er sat af, er der en km pr dag som så regnes sammen til en uge-total.

Jeg håber det giver mere mening nu

Beklager - kommer ikke videre med ovennævnte..

det vil sige at det stadig ikke står klar hvad det er jeg har brug for?
eller at du ikke har en løsning på mit problem? :-)

Jeg kan ikke se systematikken i dit regeark..

ok, jeg sletter alt fra arket som ikke har med den beregning jeg skal have lavet, og prøver at forklare i flere detaljer. Så må du melde ud hvor langt du kan følge og hvor jeg smider kæden af :-)

Så hvis du henter den på ny

https://dl.dropbox.com/u/90443028/Eksempel.xls

Kolonnen "sektions nr" har jeg sat ind for at kunne lave min formel. Den laver jeg manuelt hver gang jeg indsætter nye data i templaten.

Navn = personen der bliver kørts navn (nu erstattet med bogstaver)
kolonnerne M, T, O,T, F - er ugens dage.

De hvide rækker er folk der bliver samlet op, de grå rækker er hvor folk bliver sat af.

så hvis du ser i starten der bliver a-i samlet op en efter en, derefter bliver a,b,c,d,h sat af en efter en, j bliver samlet op og j,i,g bliver sat af en efter en - herefter bliver der noteret hvor mange km denne grupper har kørt hver dag. (de rækker jeg har noteret med t i "sektion nr"

dvs at a-i har samlet kørt 52,7 km pr dag.

de rækker som har fået sektion nr 2, bliver kun kørt fredag og kører 51,8 km samlet den dag. (regnet sammen i rækken markeret t2)

de rækker som har fået sektion nr 3 bliver kørt man-tors og kører et forskelligt antal km hver dag. (regnet sammen i t3)

Det samme med sektions nr 4 osv

I kolonnen KM har jeg delt km ud på hver enkelt passager inden for et sektionsnr. Så totalen for T1 bliver delt ud på alle 1'erne, T2 på alle 2'erne osv.

Så jeg har enten brug for at kunne lave kolonnen "sektion nr"  automatisk - eller også en måde at lave det på, hvor den kan undværes totalt - den tager nemlig en evighed at lave manuelt.

Ja - det hjalp gevaldigt - tak for det..

Hvis du skulle forenkle det mest muligt, hvordan skulle din registrering så se ud?

jeg indtaster følgende værdier manuelt:

Rutepris
regulering
sektion nr

KM og Pris Pr uge er formel felter

De resterende kolonner copy/paster jeg fra de excel ark jeg får ind - som ser ud som det du så først.

optimalt set så skulle templaten så automatisk give mig følgende oplysninger:

total antal km kørt
pris pr km
hvor mange km har hver person kørt
omkostning for hver person

hvis det besvarer dit spørgsmål

og her vil jeg som sagt gerne slippe for at skulle lave fodarbejdet med med at indtaste sektion nr

Har udarbejdet en løsning med VBA og stort set uden formler - dog p.t. med 1 sektionsnr pr. sektion (ved start - men kan nok elimineres).

Fordeling af km tager < 1 sek.

Send en mail - returnere jeg arket i neutral tilstand og med resultat.

Andre der har nogle forslag?

mange tak for hjælpen, Supertekst :-) smider du et svar, så smider jeg nogle point

OBS: Afstår fra points ..

Const opsamlingFarve = -4142        'xlColorIndexNone
Const aflæsningFarve = 15

Const ruteNrKolonne = "C"
Const mandagKolonne = "G"
Const mandagKolonneNum = 7
Const totalKmKolonne = "G"
Const prisPrKmKolonne = "H"

Const kmKolonne = "M"
Const prisPrUgekolonne = "N"

Const startRæk = 10
Dim sidsteRække As Long

Dim ræk As Long
Dim totalKm As Double, sektionsNr As Integer, antalOpsamlinger As Integer, rutenr As Integer
Public Sub beregnFordelingAfKm()
    nulstilTotalKm
   
    beregnTotalKm
   
    fordelKm
End Sub
Private Sub nulstilTotalKm()
    Range(totalKmKolonne & "2:" & totalKmKolonne & "4").Select
    Selection.ClearContents
   
    Range(kmKolonne & CStr(startRæk) & ":" & prisPrUgekolonne & "65000").Select
    Selection.ClearContents
End Sub
Private Sub beregnTotalKm()
Rem find overgangen mellem sektioner og optæl denne række
    totalKm = 0
    sektionsNr = 1                                  'første sektionsnr
    Range("B" & startRæk) = sektionsNr
   
    rutenr = Range("A" & startRæk)                  'første rutenr
   
    For ræk = startRæk To 65000
Rem stopper når kolonne C & D er tom
        If Trim(Range("C" & ræk)) = "" And Trim(Range("D" & ræk)) = "" Then
            totalKm = totalKm + optælUgensKm(ræk - 1)
            sidsteRække = ræk - 1
            Exit Sub
        Else
Rem Undersøg om totalRække - grå samt talværdier i kolonnerne G-K
            If testOmTotalRække(ræk) = True Then
                If Range("C" & CStr(ræk + 1)) <> "" Then
                    sektionsNr = sektionsNr + 1
                    Range("B" & ræk + 1) = sektionsNr
                   
                    totalKm = totalKm + optælUgensKm(ræk)
                    rutenr = Range("A" & ræk + 1)
                End If
            End If
        End If
    Next ræk
End Sub
Private Function optælUgensKm(række As Long)
Dim ugeTotal As Double, ugeDag As Integer, ruteNrRække As Integer
    ugeTotal = 0
   
    For ugeDag = 1 To 5
        ugeTotal = ugeTotal + Range(mandagKolonne & række).Offset(0, ugeDag - 1)
    Next ugeDag

Rem Indsæt i KM-kolonne for rækken
    Range(kmKolonne & række) = ugeTotal
   
Rem opdater i TotalKm iflg. rutenr
    ruteNrRække = findRuteNrRække(rutenr)
    If ruteNrRække > 0 Then
        Range(totalKmKolonne & CStr(ruteNrRække)) = Range(totalKmKolonne & CStr(ruteNrRække)) + ugeTotal
        optælUgensKm = ugeTotal
    Else
        MsgBox "Rutenr.: " & CStr(rutenr) & " er ikke fundet - afbryd kørsel"
        Stop
    End If
End Function
Private Sub fordelKm()
Dim fraRæk As Integer, tilRæk As Integer, ugeTotal As Double
   
    antalOpsamlinger = 0
    fraRæk = startRæk
    rutenr = Range("A" & startRæk)
   
    For ræk = startRæk To sidsteRække
        If Range(kmKolonne & ræk) = "" Then
            If Range("C" & ræk).Interior.ColorIndex = opsamlingFarve Then
                antalOpsamlinger = antalOpsamlinger + 1
            End If
        Else
            tilRæk = ræk
            ugeTotal = Range(kmKolonne & ræk)
           
            fordelPåPersonerOpsamlinger fraRæk, tilRæk, antalOpsamlinger, ugeTotal
            antalOpsamlinger = 0
            fraRæk = ræk + 1
            rutenr = Range("A" & CStr(ræk + 1))
        End If
    Next ræk
End Sub
Private Sub fordelPåPersonerOpsamlinger(fraRæk, tilRæk, antalOpsamlinger, ugeTotal)
Dim ræk As Long, prOpsamlingKm As Double, prisPrUge As Double, ruteNrRække As Integer
Dim kol As Integer, dagAntalKm As Double, personAntalKm As Double
    ruteNrRække = findRuteNrRække(rutenr)
    prOpsamlingKm = ugeTotal / antalOpsamlinger
    prisPrUge = Range(prisPrKmKolonne & ruteNrRække) * prOpsamlingKm
    Range(kmKolonne & tilRæk).Offset(0, 1) = Range(kmKolonne & tilRæk) * Range(prisPrKmKolonne & ruteNrRække)

    For ræk = fraRæk To tilRæk
        If Range("C" & ræk).Interior.ColorIndex = opsamlingFarve Then
            personAntalKm = 0
            For kol = mandagKolonneNum To mandagKolonneNum + 4        'Mandag - Fredag
                If Cells(ræk, kol) <> "" Then
                    antalpersonerdag = beregnAntalPersonerDag(fraRæk, tilRæk, kol)
                    dagAntalKm = Cells(tilRæk, kol)
                    personAntalKm = personAntalKm + (dagAntalKm / antalpersonerdag)
                   
                End If
            Next kol
            Range(kmKolonne & ræk) = personAntalKm
            Range(kmKolonne & ræk).Offset(0, 1) = personAntalKm * Range(prisPrKmKolonne & ruteNrRække)
        End If
    Next ræk
End Sub
Private Function beregnAntalPersonerDag(fraRæk, tilRæk, kol)
Dim ræk As Integer, antal As Integer
    antal = 0
    For ræk = fraRæk To tilRæk
        If Cells(ræk, kol).Interior.ColorIndex = opsamlingFarve And _
            Cells(ræk, kol) <> "" Then
                antal = antal + 1
        End If
    Next ræk
   
    beregnAntalPersonerDag = antal
End Function
Private Function testOmTotalRække(rækkeNr)
Dim cc
Rem er rækken grå - hvis ja er der numerisk data
    If Range("C" & rækkeNr).Interior.ColorIndex = aflæsningFarve Then
        For Each cc In Range("G" & CStr(rækkeNr) & ":K" & CStr(rækkeNr)).Cells
            If IsNumeric(cc.Value) = True And cc.Value <> "" Then
                testOmTotalRække = True
                Exit Function
            End If
        Next
    Else
        testOmTotalRække = False
    End If
End Function
Private Function findRuteNrRække(rutenr)
Dim ræk As Integer
    For ræk = 2 To 4
        If Range(ruteNrKolonne & ræk) = rutenr Then
            findRuteNrRække = ræk
            Exit Function
        End If
    Next ræk
    findRuteNrRække = 0
End Function

og selv tak..