Småmakroer

Gem med navn i celle
Makroen gemmer en projektmappe, med et navn, som hentes fra en celle i det aktive ark:

Public Sub SaveAsA1()
ActiveWorkbook.SaveAs Filename:=CStr(Range("A1").Value)
End Sub

Faneblad navngives på grund af navn i celle
Denne makro lader indholdet af en celle i et ark, bestemme arkets navn. Når indholdet af cellen ændres, ændres navnet på arket også. Denne makro skal ligge i arkets kodemodul.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("a1")) Is Nothing Then
        ActiveSheet.Name = Target.Value
    End If
End Sub

Er der kæde i cellen
Undersøger om en celle indeholder en kæde til en anden fil:

Sub chkformel()
    Dim a As Integer
    FrstTegn = InStr(1, ActiveCell.Formula, "[")
    If ActiveCell.HasFormula Then
        If FrstTegn > 0 Then
            MsgBox "Dette er en kæde"
        End If
    End If
End Sub

Vis kædereference
Hvis en celle indeholder en kæde til en anden fil viser denne funktion det sti- og filnavn, som kæden peger på.

Function VisKaede(ck)
VisKaede = Mid(ck.Formula, 2, Len(ck.Formula))
End Function

Ved at ændre makroen Chkformel til en funktion, kan man benytte disse sammen. Fx

Function ErKaede(ck)
    Dim a As Integer
    FrstTegn = InStr(1, ck.Formula, "[")
    If ck.HasFormula Then
        If FrstTegn > 0 Then
            ErKaede = True
        Else
            ErKaede = False
        End If
    End If
End Function

Er der kæde i celle A1 vises sti- ogfilnavn på kæden, ellers vises cellen tom.

Husk og vend tilbage
De to følgende makroer bruges til at huske en celleadresse og vende tilbage til denne, Variablen glPlace skal erklæres som Public i den generelle del af koden. Den første makro gemmer den nuværende placering, den næste vender tilbage til denne på et senere tidspunkt.

Læg et antal uger til ugenummer:
Denne funktion lægger et antal uger til et kendt ugenummer og returner det nye ugenummer, Funktionen har tre argumenter: nuværende ugenummer, det antal uger, der skal tillægges, og antallet af uger i indeværende år.

Function AddWeeks(UgeNr, PlusUger, AntalUger)
    If AntalUger > 53 Or AntalUger < 52 Then
        AddWeeks = "#UGEFEJL!"
    Else
        If UgeNr + PlusUger <= AntalUger Then
            AddWeeks = DateAdd("w", UgeNr, PlusUger)
        Else
            AddWeeks = DateAdd("w", UgeNr, PlusUger) - AntalUger
        End If
        Selection.ClearFormats
    End If
End Function

Function SUML(rn As Range) As Double
    mr = 0
    For Each c In rn
        If c.Value Mod 2 = 0 Then
            mr = mr + c.Value
        End If
    Next c
    SUML = mr
End Function

Function SUMU(rn As Range) As Double
    mr = 0
    For Each c In rn
        If c.Value Mod 2 <> 0 Then
            mr = mr + c.Value
        End If
    Next c
    SUMU = mr
End Function

Beregn tværsummen af tallene i en celle
Denne funktion beregner tværsummen af tallene i en celle. Står der fx 123 i A1 vil TSUM(A!) giver resultatet 1+2+3 = 6. Står der 123456 vil TSUM(A1) returnere 1+2+3+4+5+6=21

Function TSUM(ce As String) As Long
    Dim cif As Long
    For i = 1 To Len(ce)
        cif = cif + CByte(Mid(ce, i, 1))
    Next
    TSUM = cif
End Function

Beregn den reducerede tværsum af cifrene i en celle,
Funktionen ovenfor beregner tværsummen af cifrene i en celle. Denne funktion beregner den reducerede eller itererede tværsum. Det vil sige at tværsummen genberegnes, til den kun består af ét ciffer. RTSUM(A1) vil således give 3, hvis cifrene i A1 er 123456.

    For i = 1 To Len(ce)
        cif = cif + CByte(Mid(ce, i, 1))
    Next
igen:
    For i = 1 To Len(CStr(cif))
        caf = caf + CByte(Mid(cif, i, 1))
    Next
    If Len(CStr(caf)) > 1 Then
        cif = caf
        caf = 0
        GoTo igen
    End If
    RTSUM = caf
End Function

Indsæt ugedagens navn i en celle
Funktionen indsætter navnet på den ugedag, der passer til en given dato. Som input til funktionen, skal angives en dato i Excels datoformat.

Function UGEDAGNAVN(dato)
UGEDAGNAVN = Format(dato, "DDDD", vbMonday)
End Function

Indsæt arkets navn i en celle
Funktionen bruges på samme måde som alle andre funktioner. Den har ingen argumenter, men indsætter navnet på det aktuelle ark i en celle.

Denne funktion har den 'skavank' at denm kun kan bruges én gang i hver projektmappe, da den altid tager navnet fra det aktive ark, når dette ændres - også selv om funktionen bruges i et helt andet ark. Nedenstående funktion tillader at funktionen bruges i flere ark.

Function ArknavnF(rng)
Application.Volatile
ArknavnF = rng.Worksheet.Name
End Function

Den har nu fået et argument, og skal indtastes som fx =ArknavnF(A1), hvor A1 kan være en hvilken som helst celle i det ark, hvor funktionen bruges.

Korrekt ugenummer
Funktionen UGE.NUMMER(), der findes i tilføjelsesprogrammet Analysis Toolpack giver desværre ikke altid det rigtige ugenummer på dansk. Dette skyldes at man i Danmark og USA ser forskelligt på, hvad der er uge 1. Denne funktion. giver altid det rigtige ugenummer efter det danske princip, hvor uge 1, er den første uge, der indeholder en torsdag. Hvis 1. januar falder en torsdag er tilhører de foregående dage i ugen uge 53, ellers tilhører de uge 1.

Function UgeNum(IndDato as Date)
UgeNum = Int((Int((IndDato + 2924) / 7) * 28 Mod 1461) / 28 + 1)
End Function

Det viser sig, er der var en fejl i denne funktion, som viste sig med regelmæssige mellem, nemlig med intervaller på 12, 12 og 4 år, hvorefter der startes forfra med 12. Tak til Iver Jørgensen for at påpege fejlen og komme med en rigtige løsning.

Udskriv nummererede kopier
Denne funktion udskriver et antal nummererede kopier af et regneark. Antallet angives i en inputbox, og kopinummeret placeres i celle A1.

Sub UdskrivMedNummer()
    Antal = InputBox("Indtast antal kopier")
    For i = 1 To Antal
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
        Range("a1").Value = Range("a1").Value + 1
    Next i
End Sub

Find Kolonnebogstav.
Funktionen KOLONNE() i Excel, bruges til at returnere kolonneværdien af en celle. =KOLONNE(C7) vil fx returnere 3. Altså kolonnens nummer. Imidlertid har man af og til brug for at få retureneret kolonnens bogstav. Dette kan gøres med en formel, se Småtip eller man kan bruge denne funktion:

Function KolBog(ref)
KolBog = Mid(ref.Address, 2, InStr(2, ref.Address, "$") - 2)
End Function

Placere negative og positive tal i hver sin kolonne.
Denne makro ser på tallene i en markeret kolonne. Er tallene positive eller 0 bliver de stående, er de negative flyttes de til kolonnen ved siden af. Denne skal være tom, ellers overskrives eventuelle værdier i denne uden advarsel.

Sub FlytNegative()
    For Each c In Selection.Cells
        If c.Value < 0 Then
            c.Offset(0, 1).Value = c.Value
            c.Value = ""
        End If
    Next c
End Sub

Fordel indhold i enkeltceller
Denne makro ser på indholdet af den aktuelle celle og fordeler det, med en karakter i hver af cellerne til højre for. Der skal være lige så mange tomme celler, som der er tegn i cellen, der skal fordeles. Eventuelle kommaer i cellen slettes inden fordeling, mens mellemrum placeres i en tom celle.

Sub FordelIndhold()
    a = ActiveCell.Value
    For i = 1 To Len(a)
        b = Mid(a, i, 1)
        If b = "," Then GoTo ne
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = b
ne:
    Next
End Sub

Indsæt en ny række, samme sted i alle ark
Denne makro indsætter en ny række samme sted i alle ark i en mappe. Rækken indsættes lige under den række, hvor markøren er placeret i den aktive ark.

Sub IndsaetIAlle()
    a = Selection.Address
    For Each s In ActiveWorkbook.Sheets
        s.Select
        ActiveSheet.Range(a).Select
        Selection.EntireRow.Insert Shift:=xlDown
    Next s
    Sheets(1).Activate
End Sub

Senest gemt
I Word kan man indsætte feltet SaveDate i et dokument, og dermed se, hvornår dokumentet sidst har været gemt. i Excel findes den tilsvarende funktion ikke, men man kan lave den selv.

Function SidstGemt() As Double
SidstGemt = ActiveWorkbook.BuiltinDocumentProperties(12)
End Function

NB! Jeg er blev et gjort opmærksom på, at denne funktion af én eller anden grund ikke virker på alle pc'er. I stedet kan denne funktion anvendes (fra Hans Therkelsen, dk.edb.regneark):

Function SidstGemt() As Date
SidstGemt = FileDateTime(ThisWorkbook.FullName)
End Function

Er lige/Er ulige
I tilføjelsesprogrammet Analysis Toolpack findes to funktioner Er.LIGE og ER.ULIGE, der kan undersøge om et tal er lige eller ulige. Har man ikke, eller vil man ikke anvende Analysis Toolpack, kan nedenstående funktioner anvendes i stedet for. Ligesom funktionerne i Analysis Toolpack returnerer de to funktioner SAND eller FALSK.

Function ERLIGE(cel)
    If cel Mod 2 = 0 Then
        ERLIGE = True
    Else
    ERLIGE = False
    End If
End Function

Function ERULIGE(cel)
    If cel Mod 2 = 0 Then
        ERULIGE = False
    Else
        ERULIGE = True
    End If
End Function

Slet rækker i et ark på baggrund af data i andet ark
Denne makro sletter rækker i ark 1 på grundlag af data i ark2. I situationen skal man forestille sig at man har en liste, fx en vareliste, i ark1. Den består af et antal kolonner, hvor kolonne A indeholder et varenummer. Ark2 indeholder så en oversigt over varenumre, der er udgåede, eller af anden grund skal slettes fra listen i Ark1. Denne makro sammenligner de to a-kolonner, og rækker i Ark1, der også findes i Ark2 slettes.

Sub SletRaekke()
    Dim a As Variant
    For Each c In Sheets(2).Range("a:a").Cells
        If c.Value = "" Then Exit Sub
            a = c.Value
            For Each x In Sheets(1).Range("a:a").cells
                If x.Value = a Then
                    x.EntireRow.Delete shift:=xlUp
                End If
            Next x
    Next c
End Sub

I første omgang bevares oversigten over slettede data i Ark2. Ønskes denne oversigt slettet, når rækkerne i Ark1 er slettet, kan nedenstående tilføjes inden Next c:

Oversæt formler til engelsk
Når man kun har en dansk version af Excel, kan det af og til være ret uigennemskueligt, at finde ud af, hvad en given funktion hedder på engelsk. Det kan man have brug for, hvis man skal arbejde i en engelsk version af Excel parallelt med den danske. Funktionsnavne i Excel kan kun indtastes på det sprog, der hører til den installerede sprogversion. Derimod kan man sagtens flytte et regneark med danske formler til en engelsk version af Excel og omvendt. I så fald konverterer Excel selv til det pågældende sprog, men skal man taste nye formler i den engelske version, skal funktionsnavnene indtastes på engelsk. Også når man fx kommunikerer i internationale nyhedsgrupper eller andre fora, kan man have behov for at kunne angive sine formler på engelsk. Denne funktion oversætter en formel i celle til engelsk.

Function Engelsk(arg As Range)
Engelsk = Range(arg.Address).Formula
End Function

Har man fx formlen =MINDSTE(HVIS((A1:A6="Bil")*(B1:B6="Blå");C1:C6);2) placeret i A13, kan man i en tom celle skrive =engelsk(A13). I så fald returneres:

Læg mærke til at semikolon automatisk erstattes af komma, som er argumentseparator på engelsk.

Sæt mærke i A-kolonnen, hvis B-kolonnen er udfyldt.
Denne kode sætter en stjerne (*) i A-kolonnen, hvis der er data i B-kolonnen i samme række. Aktuelle data i A-kolonnen vil blive overskrevet.

Sub SaetTegniA()
    For Each c In ActiveSheet.Range("B1:B100").Cells
        If c.Value <> "" Then
            c.Offset(0, -1) = "*"
        End If
    Next c
End Sub

Udnyt statuslinjen i Excel
Det er ikke alle, der er klar over det, men via VBA, kan man selv udnytte statuslinjen i Excel til at lade sine makroer "skrive til brugeren".

indsætter indholder af celle A1 på det første ark i mappen. Prøv selv med flere varianter.

Tæl antal rækker brugt og kopier i anden kolonne
Denne makro tæller det antal rækker, der er brugt i den "længste" kolonne. Dernæst tager den indholdet af B1 og kopier lige så mange gang nedad, som der er talt rækker.

Sub TaelKopier()
    antrk = ActiveSheet.UsedRange.Rows.Count
    Range("B1").Copy
    Range("B2:B" & antrk).Select
    ActiveSheet.Paste
End Sub

Tæl hvor mange gange tallene skifter i en kolonne
Denne funktion tæller det antal skift mellem forskellige værdier, der forekommer i et område. Funktionen forudsætter at området er lodret, ikke vandret.

Function Skift(rn As Range)
    Skift = 0
    For Each c In rn.Cells
        If c.Value <> c.Offset(1, 0).Value Then
                Skift = Skift + 1
        End If
    Next c
    skift = skift - 1
End Function

Brug funktionen som alle andre funktioner, fx =SKIFT(A1:A100). Se også småtip for en formelløsning.

Funktion til beregning af kvartal
Excel har funktioner, der på grundlag af en dato kan finde måneden, året, ugen (omend med besvær), men ikke kvartalet. Den kommer så her:

Funktion, der finder første bogstav i en celle
Denne brugerdefinerede funktion finder det første bogstav i en celle og angiver den plads, det står på:

Function FoersteBogstav(celle)
    a = celle
    For i = 1 To Len(a)
        b = Mid(a, i, 1)
        If IsNumeric(b) Or b = " " Then
            c = 1
        Else
            FoersteBogstav = i
            Exit Function
        End If
    Next
End Function

Funktionen kan nemt modificeres, så den returner værdien i stedet for placeringen, eller returnerer første tal i stedet for første bogstav.

Flyt rækker til bunden
Denne makro flytter indholdet en række til bunden af et område, hvis der skrives et x i C-kolonnen ud for rækken. Rækken, der flyttes fra efterlades tom. På den nye plads indsættes en dato for "flytningen" i c-kolonnen. Makroen er en hændelsesmakro og skal ligge i kodearket for det relevante ark:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 3 And Target.Text = "x" Then
        Target.EntireRow.Cut
        Range("a65536").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        Range("C" & Selection.Row).Value = Date
    End If
End Sub

- Til top -

Skjul rækker, hvis betingelse er opfyldt
Denne makro skjuler de rækker, om hvilke det gælder, at der står x i B-kolonnen.

Sub SkjulRk()
    For Each c In Range("b1:B100").Cells
        If c.Value = "x" Then
            c.EntireRow.Hidden = True
        End If
    Next c
End Sub

Angiv Phi-værdi
Excel har en indbygget funktion PI(), der angiver værdien af PI med 16 decimaler. Denne funktion angiver værdien af en anden uendelig decimalbrøk, Phi, kaldet "det smukkeste talforhold i verden", "det gyldne snit" mm. Også denen værdi angives med 16 decimaler, hvilket er det største antal, som Excel kan håndtere.

Flyt mailadresse til højre
I en kolonne står en række tekster hvoraf nogle er mailadresser. Disse øsnkes flyttet en kolonne til højre, men skal blive i samme række. Marker cellerne, som indeholder teksten og afspil denne makro:

Sub FlytMail()
    For Each c In Selection.Cells
        If InStr(1, c.Value, "@") <> 0 Then
            c.Offset(0, 1) = c.Value
            c.ClearContents
        End If
    Next c
End Sub

- Til top -

Konverter tekst til tal og tal til tekst
Disse to makroer konverterer henholdsvis tal til tekster og tekster (i form af tal) til tal. Marker de celler, der skal konverteres og afspil den relevante makro. Indeholder en af cellerne en egentlig tekst (andet end talværdier) ændres denne ikke, hverken ved konvertering den ene eller anden vej.

Sub TalTilTekst()
    For Each c In Selection.Cells
        c.Value = "'" & c.Value
    Next c
End Sub

Sub TekstTilTal()
    On Error Resume Next
    For Each c In Selection.Cells
        c.Value = c.Value * 1
    Next c
End Sub

Fyld celler nedad
Af og til har man brug for at kopiere indholdet af en celle nedad. Denne makro, tager indholdet af den aktive celle i en given kolonne, fx D-kolonnen og kopierer det lige så langt ned, som der er udfyldte celler i en anden kolonne, her B-kolonne. Koden vil formodentlig sjældent blive brugt alene, da det typisk vil være hurtigere at kopiere manuelt. Derfor vil den nok forekomme som en del af en større rutine, der gør noget andet, før indholdet af en celle skal kopieres.

Sub KopierNed()
    Dim ref As String, kb As String, rk As Long
    kb = Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
    rk = ActiveSheet.Range("b65536").End(xlUp).Row
    Selection.AutoFill Destination:=Range(ActiveCell.Address & ":" & "$" & kb & "$" & rk
End Sub

Konverter datoer i andre formater til "rigtige" datoer
Disse to makroer konverterer indtastninger i forskellige formater til datoer i et Excel-genkendeligt format. Den første konverterer datoer på formen 03.11.47 til datoer på formen 03-11-1947:

Sub TilDato()
    For Each c In Selection.Cells
       c.Value = Replace(c.Value, ".", "-")
       c.NumberFormat = "dd-mm-yyyy"
    Next c
End Sub

Den næste konverter cpr-numre på formen 101320855 eller 0101320855 til datoer på formen 01-01-1932:

Sub CprTilDato()
    For Each c In Selection.Cells
        If Len(c.Value) = 10 Then
            c.Value = Left(c.Value, 2) & "-" & Mid(c.Value, 3, 2) & "-" & Mid(c.Value, 5, 2)
        Else
            c.Value = Left(c.Value, 1) & "-" & Mid(c.Value, 2, 2) & "-" & Mid(c.Value, 4, 2)
        End If
    Next c
End Sub

Indsæt billeder med navne fra ark.
Denne makro gennemløber nogle udpegede celler (her A1 til A20). Disse celler indeholder navne (men ikke sti og filtype) for billedfiler. Sti og filtype indsættes i stedet direkte via makroen. Dette kræver at såvel sti som filtype er ens for alle billeder.

Sub IndsaetBilleder()
    On Error Resume Next
    For Each c In Range("A1:A20").Cells
        c.Offset(20 0).Select
        ActiveSheet.Pictures.Insert("C:\billeder\" & c.Value & ".jpg").Select
    Next c
End Sub

Findes et billede ikke, fortsættes til det næste. Billederne indsættes 20 rækker under den række, hvor navnet står. Koden kan nemt ændres, så både sti, filnavn og filtype hentes direkte fra regnearket, hvilket er nødvendigt, hvis ikke sti og/eller filtype er ens i alle tilfælde.

Kopier et område og indsæt det flere gange
Denne makro kopierer et markeret område og indsætter dette med udgangspunkt i den første tomme celle i samme kolonne, som den aktive celle i markeringen. Indsættelsen gentages et antal gange, som specificeres ved hjælp af en dialogboks. Alle indsættelserne sker lige under hinanden.

Sub KopierMarkering()
    Selection.Copy
    For i = 1 To InputBox("Indtast antal kopieringer")
        Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    Next i
End Sub

Udskift en enkelt karakter
At udskifte et tegn i en tekst, kan gøres med funktionen UDSKIFT, eller det kan gøres med Søg og Erstat. Her er en makro, der udskifter et enkelt tegn i de markerede celler.

Sub FjernPunktum()
    Dim tegn1 As String
    Dim tegn2 As String

    tegn1 = InputBox("Indtast den karakter, der skal erstattes")
    tegn2 = InputBox("Indtast den karakter, der skal sættes ind i stedet" & vbCrLf & "For at erstatte med ingenting, klik OK")
For Each c In Selection.Cells
c.Value = Replace(c.Value, tegn1, tegn2)
Next c
End Sub

Slet rækker med flettede celler
Denne makro sletter rækker, hvor de første otte kolonner er flettet sammen til en enkelt kolonne. Makroen ser kun på de rækker i A-kolonnen, der er brugt. Er de første otte kolonner flettet sammen, slettes hele rækken, ellers lades den tilbage. Skal der være flere eller færre sammenflettede celler ændres 9 i femte linje til det relevante. Tallet repræsenterer nummeret på den første ikke-flettede kolonne.

Sub SletFlettedeCeller()
    Dim CeCo As Double
    CeCo = Range("A" & Rows.Count).End(xlUp).Row
        For i = CeCo To 1 Step -1
            If Range("A" & i).Offset(0, 1).Column = 9 Then
                Range("a" & i).EntireRow.Delete
            End If
        Next
End Sub

Find alle priser fra given dato
I et regneark findes der i kolonne A, nogle datoer. I kolonne B står nogle produktnavne og i Kolonne C nogle tilhørende priser.Vi vil nu gerne kunne angive en dato i en celle (her E1) og så få returneret alle produktnavne med tilhørende pris for den pågældende dato. I eksemplet returneres produktnavne og priser i henholdsvis kolonne G og H:

Sub ReturnerPris()

    For Each c In Range("A1:A4").Cells
        If c.Value = Range("e1").Value Then
        i = i + 1
            Range("g" & i).Value = c.Offset(0, 1).Value
            Range("h" & i).Value = c.Offset(0, 2).Value
        End If
    Next

End Sub

Fyld højre
Under (Excel 2007) fanebladet Startside, i gruppen Redigering findes knappen Fyld. Her kan man blandt andet fylde nedad, opad, til højre og til venstre. Funktionerne bruges til at udfylde et markeret område, med noget, det står i den første (eller sidste) markerede celle i området. Funktionen Fyld nedad har genvejstasten Ctrl+D, men der er ikke genveje til de øvrige retninger. Det råder denne makro bod på. Knyt den selv til en relevant genvejstast. Makroen fylder til højre.

Makroer til de øvrige retninger laves ved at ændre til FillUp og FillLeft. FillDown vil også virke, men den findes jo allerede :-).

Skjul rækker på baggrund af celleindhold
Vi har brug for at skjule eller vise rækker på baggrund af indholdet af to celler. Hvis celle indholdet i A1 er større end indholdet af A2 skal række 15 til 25 skjules. Dette gøres nemt med en såkaldt hændelsesmakro. Den skal se ud som følger

Private Sub Worksheet_Change(ByVal Target As Range)

    If Range("A1") > Range("A2") Then
        Rows("15:25").EntireRow.Hidden = True
    Else
        Rows("15:25").EntireRow.Hidden = False
End If

End Sub

Worksheet_Change hændelsen indtræffer hver gang der ændres i en celle i arket. I dette tilfælde har det kun praktisk betydning, hvis der ændres i en af de to celler. Makroen er en hændelsesmakro og skal ligge i kodearket for det relevante ark.

Fyld tomme celler med indhold
Denne makro fylder tomme celler i et markeret område, med et indhold, der indtastes i en inputbox. Fx kan tomme celler fyldes med tekst eller tal.

Sub FyldTom()

    Dim Indhold As String
    Indhold = InputBox("Indtast det, tomme celler skal udfyldes med.")

    For Each c In Selection.Cells
        If IsEmpty(c) Then c.Value = Indhold
    Next c

End Sub

Beregn den n'te rod af et tal
Den n'te rod af et tal kan i Excel beregnes med denne formel: tal ^ 1/n eller med ord, tallet opløftet til en potens, der hedder 1 divideret med den ønskede rod. Fx vil 8^1/3 give resultatet 2, altså den tredje rod af 8. Denne funktion virker på samme måde som kvadratrodsfunktionen. Den har de to argumenter tal og rod og =NROD(125;3) vil så give resultatet 5, altså den tredje rod af 125.

Tæl antal celler med tekst
Excel har to indbyggede funktioner, TÆL() som tæller antallet af celler med tal i et område og TÆLV(), som tæller antallet af udfyldte celler i et område. Ved at trække disse to fra hinanden, kan man så regne ud, hvor mange celler, der indeholder tekster. Denne funktion gør det dog direkte. TÆLT(A1:A23) vil således tælle de celler i området, der kun indeholder tekst uanset om denne er tastet eller er resultatet af en formel.

Function TælT(rn As Range)
    Dim counter As Long
    For Each c In rn.Cells
        If Not IsNumeric(c.Value) Then
            counter = counter + 1
        End If
    Next c
    TælT = counter
End Function

Tæl antal celler, der indeholder formler
Som tilfældet med ovenstående funktion, har Excel ikke en indbygget funktion, der tæller hvor mange celler i et område, der indeholder en formel. Det klarer nedenstående. Med 1 i A1, 4 i A2 og =A1*A2 i A3 vil TÆLF(A1:A3) returnere 1.

Function TælF(rn As Range)
    Dim counter As Long
    For Each c In rn.Cells
        If c.HasFormula Then
            counter = counter + 1
        End If
    Next c
TælF = counter
End Function

Beregn talværdi af en tekst
Denne funktion beregner talværdien af en tekst. Funktionen forudsætter at hvert bogstav, der skal beregnes værdi for, skrives i en kolonne i filen, og den tilhørende talværdi skrives i kolonnen til højre for. I M1 til M29 har man bogstaverne fra A til Å og i N1:N29 de tilhørende værdier, fx 1 til 29. Med teksten "Talværdi" i A1 vil =TALVAERDI(A1;M1:N29) returnere 113.

Function Tekstvaerdi(celle, ar As Range) As Long
    a = UCase(celle)
    For i = 1 To Len(a)
        b = Mid(a, i, 1)
        For Each c In ar.Cells
            If UCase(c.Value) = b Then
                tael = tael + c.Offset(0, 1).Value
            End If
        Next
    Next
Tekstvaerdi = tael
End Function

Sikre at et regneark først kan udskrives når bestemte celler er udfyldt
I artiklen BeforePrint hændelsen i Excel, under Makroer, fortæller jeg generelt om, hvordan hændelsen BeforePrint, der er knyttet til Workbook-modulet kan udnyttes til at gøre ting ved regnearket før det udskrives. Her anvendes hændelsen til at sikre, at et regneark kun kan udskrives, hvis bestemte celler (her A1 og B1) er udfyldt. Koden skal altså anbringes Workbookmodulet.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    If IsEmpty(Range("a4")) Or IsEmpty(Range("a5")) Then
        MsgBox "Husk at udfylde celle A4 og A5", vbOKOnly + vbInformation
        Cancel = True
    End If
End Sub

Vis skjulte rækker i et bestemt område i alle ark med en bestemt navn
En projektmappe indeholder et større antal ark, som alle har nogle rækker i et bestemt område, her rækker 20 til 50, som kan være skjulte eller ikke. Arkene i mappen har forskellige navne. Denne makro viser alle rækker i det pågældende område for de ark, hvis navn begynder med "projekt".

Sub VisSkjulte()
    For Each s In ActiveWorkbook.Sheets
        If UCase(Left(s.Name, 7)) = "PROJEKT" Then
            s.Range("A20:A50").EntireRow.Hidden = False
        End If
    Next s
End Sub

- Til top -

Tæl antal af en bestemt karakter i en celle
Denne funktion tæller antallet af et nærmere specificeret tegn i en given celle. Der er tale om en funktion med to argumenter, cellen, der skal undersøges, og karakteren, der skal findes.

Function TTEGN(ce As String, ct As String) As Long
    Dim ant As Long
    For i = 1 To Len(ce)
        If CStr(Mid(ce, i, 1)) = ct Then
            ant = ant + 1
        End If
    Next
    TTEGN = ant
End Function

Find sidste forekomst af tegn i streng
Denne funktion finder positionen af den sidste forekomst af en streng i en anden streng. Den har samme funktion som FIND(), men søger bagfra. Har du strengen "abcabcabc" i A1, kan du finde det sidste "a" med =Findsidste(A1;"a"). Husk at strenge skal stå i anførselstegn. Resultatet bliver her 7, fordi det sidste a står på 7. position i strengen.

Function FindSidste(cel, tegn)
FindSidste = InStrRev(cel, tegn, , 1)
End Function

Opdel celleindhold i to
Denne funktion er en udvidelse af funktionen, der finder første bogstav i en celle. Denne funktion finder også første bogstav i en celle, men i stedet for at returnere bogstavets placering, returnerer den resten af cellens indhold som en tekststreng. "123 SS 12 SAA" vil således blive returneret som "SS 12 SAA", mens "123AB" vil blive returneret som "AB". Som det fremgår regnes mellemrum ikke som bogstaver.

Function OpdelCelle(cel)
    For i = 1 To Len(cel)
        If Not IsNumeric(Mid(cel, i, 1)) And Mid(cel, i, 1) <> " " Then
            Exit For
        End If
    Next i
    OpdelCelle = Mid(cel, i, Len(cel))
End Function

Tom række efter SUBTOTAL
Denne kode indsætter en tom række under rækker med Subtotaler i ark, hvor subtotalfunktionen eller subtotalformler er brugt. Koden kan køres i en selvstændig makro, eller kan integreres i en makro, der gør andre ting, fx indsætter subtotaler. I så fald skal den indsættes sidst i denne makro.

For Each c In Range("G1:G100").Cells
    If Mid(c.Formula, 2, 8) = "SUBTOTAL" Then
        c.Offset(1, 0).EntireRow.Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If
Next

Makroen her forudsætter at der er subtotaler i kolonne G, men dette kan nemt rettes til enhver anden kolonne.

Funktion til beregning af rest af division
I artiklen Fejl i funktionen Rest() under Småtips fortæller jeg at den indbyggede funktion REST() ikke virker, ved store tal. Helt præcist hvis divisoren gange 134.217.728 er mindre end det tal, der skal undersøges. Jeg giver også forslag til løsning af problemet. En anden mulighed er at bruge denne funktion.

Function Resten(tal, divisor)
Resten = tal - (Int(tal / divisor) * divisor)
End Function

Funktion til at sikre at en mappe altid åbes i Automatisk beregning
En tilsyneladendce fejl i Excel betyder at nogle projektmapper altid åbnes i manuel beregningsindstilling, selv om de er gemt i, og Excel indstillet til automatisk. Det kan løses ved at lægge denne kode i disse mappers ThisWorkbook modul.

Tælle, hver gang en bestemt celle aktiveres
Denne makro laver en optælling i A1 af, hvor ofte B1 aktiveres. Er det andre celler, der tælles rettes referencerne i makroen. Dette er en hændelsesmakro, der skal placeres i det relevante arks kodemodul.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("b1")) Is Nothing Then
        Range("a1").Value = Range("a1").Value + 1
    End If
End Sub

Første bogstav i celle med stort
Excels indbyggede funktion STORT.FORBOGSTAV konverterer det første bogstav i hvert ord til store bogstaver. "oles nye autobil" bliver derfor til "Oles Nye Autobil". Nedenstående funktion konverterer kun det første tegn i cellen til stort, og kun hvis tegnet er et bogstav."12abc" vil således forblive 12abc, hvor den indbyggede funktion konverterer til 12Abc. I den indbyggede funktion konverteres helt numeriske værdier, fx 1234 til en tekststreng med samme værdi. I denne funktion forblver numeriske værdier numeriske.

Function StortFoerste(cel As Variant) As Variant
    If Not IsNumeric(cel) Then
        cel = UCase(Left(cel, 1)) & LCase(Mid(cel, 2, Len(cel)))
        StortFoerste = cel
    Else
        StortFoerste = cel
    End If
End Function

Tilpasning af sideopsætning
Denne makro tilpasser sideopsætningen i en mappe. Der kunne naturligvis medtages adskilligt flere sideopsætningsparametre, men makroen opfylder som sædvanligt et ønske :-). I alle ark i mappen, slås Udskriv gitterlinjer til. Margener sættes til 2 cm og alle kolonner autotilpasses.

Sub TilpasSide()
    For Each s In ActiveWorkbook.Worksheets
        s.Cells.EntireColumn.AutoFit
        With s.PageSetup
            .PrintGridlines = True
            .LeftMargin = Application.CentimetersToPoints(2)
            .RightMargin = Application.CentimetersToPoints(2)
            .TopMargin = Application.CentimetersToPoints(2)
            .BottomMargin = Application.CentimetersToPoints(2)
        End With
    Next s
End Sub

Farv celler med formler blå
Denne makro farver alle celler i det aktive ark blå, hvis de indeholder en formel.

Sub FarvFormler()
    'Undersøger den del af regnearket, der er brugt og
    'farver celler, med formler blå
    For Each c In ActiveSheet.UsedRange.Cells
        If c.HasFormula Then
            c.Interior.ColorIndex = 5
        End If
    Next c
End Sub

Farven kan ændres til noget andet, ved at ændre værdien 5 til et andet tal mellem 0 og 55.

Sorter automatisk efter kolonne ved indtastning
Hv er gang der indtastes i A-kolonnen, hvad enten det er tal eller bogstaver, sorteres kolonnen, så det indtastede sættes på rette plads. Der sorteres i stigende orden. Koden skal ligge i det relevante arks kodemodul. Kolonnen kan nemt rettes til noget andet end A.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("a:a")) Is Nothing Then
        Range("A:A").Sort Key1:=Range("A6"), Order1:=xlAscending, Header:= _
          xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
          DataOption1:=xlSortNormal
    End If
End Sub

Beregn alder fra fødselsdag
Denne funktion beregner alderen ud fra en fødselsdag.

Public Function Alder(datFoed As Date) As Integer
'Beregn alder ud fra en fødselsdag
'Funktionen kan kaldes med fødselsdagen som argument

Alder = Right(DatePart("yyyy", Date - datFoed), 2)
End Function

Indsæt tomme rækker og kopier
Denne makro indsætter to rækker under en markeret række og kopierer indholdet af den markerede række til de to nye.

Sub Indsæt_og_kopier()

    Selection.Copy
    Rows(Selection.Rows & ":" & Selection.Rows + 1).Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

End Sub

- Til top -

Åbn regneark med dags dato markeret
I række to i et regneark står årets datoer i række 2. Når regnearket åbnes, skal den celle, der indeholder dags dato være aktiveret.Dette gøres med denne makro:

Sub Workbook_Open()
    For Each c In Range("a2:nb2").Cells
        If c.Value = Date Then
            c.Activate
            Exit Sub
        End If
    Next
End Sub

- Til top -

Kopier skabelon, sæt ind og omdøb ark
Denne ret simple makro kopierer en skabelon, indsætter kopien sidst i projektmappen og omdøber den til 'Sag n', hvor 'n' er et nummer højere end det seneste sagsnummer. Inden makroen køres, skal der være to ark i mappen. Skabelonen, som ligger som første ark, og heder 'Skabelon', samt et ark, der hedder 'Sag 1'. Hvis der er andre ark i mappen, skal de ligge før arket 'Skabelon'.

Sub KopierogOmdøb()
    Dim LastSheet As Integer, NewLast As Integer, LastName As String, Numb As Integer

    LastSheet = Sheets.Count
    NewLast = LastSheet + 1
    LastName = Sheets(LastSheet).Name
    Numb = Mid(LastName, 5, Len(LastName))

    Sheets("Skabelon").Select
    Sheets("Skabelon").Copy after:=Sheets(LastSheet)
    Sheets(NewLast).Name = "Sag " & Numb + 1
End Sub

- Til top -

Fremhæv aktiv række og kolonne
Denne kode fremhæver den række og den kolonne, som den aktive celle står i.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex = 0 'reset background color all cells 'Sletter foregående fremhævning
    ActiveCell.EntireRow.Interior.ColorIndex = 7 'Fremhæver række
    ActiveCell.EntireColumn.Interior.ColorIndex = 7 'Fremhæver kolonne
End Sub

Vil man kun fremhæve række eller kolonne, kan en af de to sidste linjer kommenteres ud eller slettes.

Læg en til celle ved dobbeltklik
Dette er en såkaldt hændelsesmakro, der udnytter hændelsen Before_Doubleclick, og som altså indtræffer, når man dobbeltklikker i en celle. Hvis cellen indeholder et tal, lægges der en til dette tal. Indeholder cellen en tekst eller er den tom, virker dobbeltklik som normalt. Funktionen virker på alle celler i regnearket, men kan ret nemt begrænses til et celleområde.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not IsEmpty(Target.Value) Then
        If IsNumeric(Target.Value) Then
            Target.Value = Target.Value + 1
            Cancel = True
        End If
    End If
End Sub

- Til top -

Skift skrift på del af celle
Opgaven her går ud på at skrifteskriftegenskaber for en del af en celles indhold, her den sidste del. I hver celle står et navn og en arbejdsgiver, adskilt med komma, fx "Jens Jensen, ABCD Aps", "Victoria Vandhund, Svømmevesten A/S" og så videre. Der ønskes nu skift af arbejdsgivernavnet til en anden skrifttype, -farve, -størrelse eller lignende. Den konkrete makro ændre skifttype og fontstørrelse.

Sub Skiftskrift()
    For Each c In Selection.Cells
        navn = InStrRev(c.Text, ",")
        With c.Characters(Start:=navn + 2, Length:=Len(ActiveCell)).Font
            .Name = "Calibri"
            .Size = 20
        End With
    Next
End Sub

Er det andre ting, der skal ændres , er det bare at tilføje eller rette disse inden for With-gruppen.

- Til top -

Åbn rulleliste, når celle aktiveres
En celle indeholder en rulleliste dannet ved hjælp af datavalidering. I stedet for at man skal klikke på rullelistepilen for at åbne listen, skal denne åbnes i det øjeblik den pågældende celle aktiveres. Dette klares med denne makro, som er en hændelsesmakro, der skal ligge i kodemodulet for det ark, der indeholder rullelisten. I eksempelt er det C1, der indeholder rullelisten.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C1")) Is Nothing Then
        Application.SendKeys ("%{down}")
    End If
End Sub

- Til top -

Vis filnavn mm i celle
Denne funktion anvendes til at vise filnavn, sti, samt arknavn i en celle og er egentlig en udvidelse til funktionen ArknavnF, som kan findes i Jans Udvidelser under Færdige eksempler.

Function Filnavn(art)
    Application.Volatile
    Select Case art
        Case Is = 1
            Filnavn = ActiveWorkbook.Name
        Case Is = 2
            Filnavn = ActiveWorkbook.Path
        Case Is = 3
            Filnavn = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        Case Is = 4
            Filnavn = Range("a1").Worksheet.Name
        Case Is = 5
            Filnavn = ActiveWorkbook.Name & "!" & Range("a1").Worksheet.Name
        Case Is = 6
            Filnavn = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & "!" & Range("a1").Worksheet.Name
        Case Else
            Filnavn = CVErr(xlErrNA)
    End Select
End Function

Funktionen har et argument, som kan antage seks forskellige værdier fra 1 til 6. 1 viser navnet på projektmappen. 2 viser mappens sti, 3 viser sti og navn, 4 viser navnet på det ark, funktionen findes i, 5 viser mappe og arknavn, mens 6 vider sti, mappe og ark. Bruges andre argumenter vises fejlen #I/T!, som indkerer at der ikke er et tilgængeligt svar.

- Til top -

Sammenlign celler og ryk ned
I to kolonner står nogle værdier. I A-kolonnen står alle værdier, i B-kolonnen nogle af disse, som vist i eksemplet til venstre. Værdierne står altid i samme rækkefølge i begge kolonner, og dubletter forekommer ikke i nogen af kolonnerne. Nu ønskes værdierne i B kolonnen placeret ud for de tilsvarende værdier i A kolonnen. Det klarer denne makro:

Sub Tjekogryk()
    For Each c In Range("A1:A100").Cells
        If c.Value <> c.Offset(0, 1).Value Then
            c.Offset(0, 1).Select
            Selection.Insert Shift:=xlDown
        End If
    Next
End Sub

Området skal naturligvis tilpasses til det antal celler, der er i A-kolonnen.

- Til top -

Find dato i kolonne og returner rækkenummer
Denne makro, der er en funktion, søger efter en givet dato i en given kolonne. Hvis datoen findes i den pågældende kolonne, returneres rækkenummeret, hvor datoen står. Findes datoen ikke, returneres #I/T! Makroen forudsætter, at der ikke er tomme celler i den kolonne, der undersøges.

Function HvorErDato(Kolonne As Single, Dato As Date)
    For Each c In Columns(Kolonne).Cells
        If c.Value = Dato Then
            HvorErDato = c.Row
            Exit Function
            If c.Value = "" Then Exit For
        End If
    Next
    If HvorErDato = 0 Then HvorErDato = CVErr(xlErrNA)
End Function

- Til top -

Forhindre klip og/eller kopier
Hvis man vil forhindre at brugere klipper eller kopierer og sætter ind i et regneark, kan man naturligvis beskytte regnearket, mena af og til er det faktisk kun klip og/eller kopier, man vil forhindre. Det kan gøres med denne makro:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.CutCopyMode = False
End Sub

Det er som navnet antyder, tale om en hændelsesmakro, der skal ligge på kodearket, for det regneark, det skal gælde i. Har man valgt (ved hjælp af mus eller tastatur) at kopiere eller klippe en celle eller et område, vil den anvendte funktion blive ophævet, når man flytter til et andet sted i arket, og man derfor ikke sætte ind. Det er derimod muligt at indsætte i andre programmer, så længe man ikke flytter væk fra den kopierede/klippede celle i Excel. Man skal dog verfe opmærksom på, at det "klippede" ikke forsvinder fra den celle i Excel, man har klippet fra. Ønsker man kun at forhindre "klipning, men ikke kopiering elelr omvendt, kan man udvide makroen:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Application.CutCopyMode = xlCut Then
        Application.CutCopyMode = False
    End If
End Sub

Vil man forhindre kopier, men tillade klip, skal xlCut erstattes med xlCopy. Vil man også forhindre brugen af Fyldhåndtaget, kan dette gøres under Excels indstillinger. Vælg simpelthen Filer - Indstillinger. I fanebladet Avanceret fjerne man fluebenet ud for Aktiver fyldhåndtaget samt træk og slip af celler.

- Til top -

Udvid kolonnebredden successivt med 2
Denne makro gør hver kolonne to bredere end den foregående. I eksemplet sættes den første kolonne til 9 og derefter forøges med 2. Ved at rette udgangspunktet og forøgelsen, kan dette ændres til alle mulige kombinationer.

Sub OegKolonneBredde()
    Dim bred As Double
        bred = 9
        For Each col In ActiveSheet.Range("A:AZ").Columns
            col.ColumnWidth = bred
            bred = bred + 2
        Next col
End Sub

Makroen her arbejder i kolonnerne A til AZ men også dette kan naturligvis ændres.

- Til top -

Vis Excels versionsnummer
At få vist Excels versionsnummer kan gøres meget simpelt:

Sub version()
MsgBox Application.version
End Sub

Så vises versionsnummeret i en meddelelsesboks. Skal man bruge det i en variabel, fordi man skal arbejde videre med det, kan det gøres således:

Sub Version()
    Dim VerNum As Variant
    VerNum = Application.version
    MsgBox VerNum
End Sub

Beregn alder ud fra fødselsdag, version 2
Denne brugerdefinerede funktion beregner alderen ud fra en dato i Excels datoformat, "dd-mm-åå".

Function Alder(Dato As Date) As Integer

    If Month(Dato) > Month(Date) Or Month(Dato) = Month(Date) And Day(Dato) > Day(Date) Then
        Alder = DateDiff("yyyy", Dato, Now) - 1
    Else
        Alder = DateDiff("yyyy", Dato, Now)
    End If
End Function

Hvis datoen står i A1, kan alderen beregens med =Alder(a1).

- Til top -

Søg i A efter markeret værdi i D eller E
Et regneark indeholder en række elementer, hver med en unik nøgle i A-kolonnen. I D og E kolonnerne står referencer til en uniknøgle i en anden række, som en slags "relationsdatabase" med fremmednøgle, fx

Nøgle   Værdi    Værdi Fremmednøgle1   Fremmednøgle2
4711    bla       bla        4712                4713
4712    bla       bla        4719                4720
4713    bla       bla        4789                4790

Ved at markere en nøgle i enten D eller E-kolonnen, og klikke på en knap, skal den række, der indeholder "fremmednøglen" der er valgt i A-kolonnen markeres. Denne kode på knappen løser opgaven. Hvis den nøgle, man har market i D eller E kolonnen, ikke findes i A-kolonnen, vises en fejlmddelelse.

Sub Viselement()
    On Error GoTo Fejl
    Dim soe As String
    Soeg = ActiveCell.Value
    ActiveSheet.Columns(1).Find(Soeg, After:=Range("a1")).EntireRow.Select
Fejl:
    If Err.Number = 91 Then
        MsgBox "Den søgte person findes ikke i A-kolonnen. Prøv at markere en anden.", _
            vbExclamation + vbOKOnly
    End If
End Sub

- Til top -

Skift til bestemt ark ved indtastning
I et givet ark, her i celle C1 indtastes et tal. I de øvrige ark i mappen står der et tal i A1. Det samme tal kan ikke stå i mere end ét ark. Når der tasts i C1 i indtastningsarket, skiftes automatisk dtil det ark, hvor det pågældende tal står i A1. Tastes der et tal, som ikke står i A1 i noget af arkene, sker der intet.Antallet af ark i mappen er ligegyldigt, bare der står et entydigt tal i A1. Denne kode, som skal lægges på Arkmodulet i det ark, hvor der tastes i C1.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Not Intersect(Target, Range("C1")) Is Nothing Then
        For Each s In ActiveWorkbook.Sheets
            If s.Range("a1") = Target.Value Then
                s.Activate
                Exit Sub
            End If
        Next s
    End If
    Application.ScreenUpdating = True
End Sub

- Til top -

Skift indhold i ark afhængigt af indhold i andet ark
Hvis tal i kolonne D i Ark1 findes i kolonne B i Ark2 skal kolonne B i Ark1 sættes lig 100. Denne kode løser opgaven.

Sub Udfyld()
    Dim ende As String, ende2 As String

    ende = Range("d1").End(xlDown).Address
    ende2 = Sheets(2).Range("b1").End(xlDown).Address

    For Each c In Sheets(1).Range("d1:" & ende).Cells
        For Each d In Sheets(2).Range("b1:" & ende2).Cells
            If c.Value = d.Value Then
                c.Offset(0, -2) = 100
            End If
        Next d
    Next c
End Sub