Automatisk indskrivning af tal i skema

Udfordring:

I et regneark (se nedenfor), findes i kolonne A (fra række 6 til ca. 200 nogle varenumre.  Kolonne B indeholder en summering af tallene i samme række. I række 2 står ugenumre angivet som tekst, fx "Uge 3". I række 5 summeres tallene i de enkelte kolonner.

                     
    Uge 01 Uge 02 Uge 03 Uge 04 Uge 05 Uge 06 Uge 07 Uge 08 Uge 09
Vare.nr.                    
  Sum                  
  976 211 204 0 40 58 442 0 21 0
19 100 5 19   19 4 39   14  
12 69 15 19   3 4 28      
78 176 10 35   17 1 112   1  
102 212 67 31     10 102   2  
444 125 26 36     6 53   4  
123 183 32 31     23 97      
123 111 56 33   1 10 11      


I B3 (ved siden af Vare.nr.) indtastes et varenummer og i C3 et antal. Dette antal skal nu overføres til den korrekt uge, beregnet på grundlag af datoen for indtastningen) i rækken ud for det relevante varenmummer. Indtastes fx den 2. marts varenummer 444 i B3 og 17 i C3, skal der skrives 17 i K10, da datoen fin des i uge 9. Ugenummeret beregnes på baggrund af pc'ens indstillede dato.

Denne løsning er baseret på hændelsen Worksheet_Change og afspilles derfor automatisk, når denne hændelse indtræffer i den relevante celle, men den kunne også have været skrevet som en "almindelig" makro og afspillet manuelt.

 
Koden virker på den måde, at når man taster et antal i C3 (udløsercellen). vil den se på B3, om denne celle er udfyldt. Hvis det ikke er tilfældet, får man en meddelelse om, at både varenummer og antal skal være udfyldt. Står der et populationsnummer, vil den se om dette findes i A-kolonnen. Gør det ikke det, får man en meddelelse om dette, og både B3 og C3 tømmes. Såfremt begge celler er udfyldt, og populationsnummeret findes, vil den skrive antallet i den aktuelle uge ud for det pågældende populationsnummer.
 
NB! Husk at ændringer i et arket, der foretages via makro, ikke kan fortrydes med fortryknappen, så hvis man taster forkert varenummer eller antal, må arket rettes manuelt.

I eksemplet nedenfor er koden kommenteret, så man kan se, hvad de enkelte dele gør.
 

 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo errhan
 
'Først skal vi lige erklære nogle variable.

    Dim r As Integer, co As Integer, unr As Byte, runr As String

'Så går vi i gang og undersøger først et par ting om indtastningen.
' Er der tastet i den celle, der udløser funktionen (C3), ellers ignorer.

   
    If Not Intersect(Target, Range("c3")) Is Nothing Then

' Er cellen tom, er det nok fordi indholdet er blevet slettet. Så skal der ikke ske noget.

        If IsEmpty(Target) Then
            Exit Sub
        End If
 
'Står der et varenummer i B3? Det skal der, ellers gives en advarsel og funktionen stoppes.
 
        If IsEmpty(Range("b3")) Then
            MsgBox "Både antal styk og population skal være udfyldt", vbOKOnly + vbCritical
            Exit Sub
        End If
 
'Hvis alt er i orden forsættes koden.
'Først findes det korrekte ugenummer på baggrund af pc'ens værdi for dags dato.
'Ugenumrene i række 2 skal være indtastet som fx Uge 01. Der må ikke være dobbeltmellemrum mellem tekst og tal.

 
        unr = Int((Int((Date + 2924) / 7) * 28 Mod 1461) / 28 + 1)
 
'Det fundne ugenummer sammenkædes med teksten Uge. Det undersøges om dcer skal indsættes et 0 før ugenummeret.
'Dette sker, hvis det fundne ugenummer kun har et ciffer. Ellers bruges det fundne ugenummer direkte.

 
        If Len(unr) = 1 Then
            runr = "uge 0" & unr
        Else
            runr = "uge " & unr
        End If
 
'Så findes det rækkenummer, hvor det indtastede varenummer står.
 
        For Each c In Range("a6:a300").Cells
            If c.Value = Range("b3").Value Then       
                r = c.Row
            End If
        Next c
 
'Så findes kolonnenummeret for den relevant uge.
 
        For Each d In Range("c2:z2").Cells
            If d.Value = runr Then
                co = d.Column
            End If
        Next d
 
'Så skrives det indtastede stykantal i den relevante celle og
'Indholdet i indtastningscellerne slettes.

 
        Cells(r, co).Value = Range("c3").Value
        Range("c3").ClearContents
        Range("b3").ClearContents

    End If

    Exit Sub
 
'Fejlhåndtering
 
errhan:
 
    If Err.Number = 1004 Then
        MsgBox "Du har indtastet et populationsnummer, der ikke findes i A-kolonnen" & vbCrLf & "Ret nummeret og prøv igen", vbOKOnly + vbInformation
 
        Range("c3").ClearContents
        Range("b3").ClearContents
        Exit Sub
    End If
 
End Sub