Småmakroer

Her følger en række mindre makroer til løsning af enkle, konkrete opgaver.

Fremhæv aktiv række og kolonne (Ny 7-5-17)
Kopier skabelon, sæt ind og omdøb ark
Åbn regneark med dags dato markeret
Indsæt tomme rækker og kopier
Beregn alder på grundlag af fødselsdag (Funktion)
Sorter efter kolonne automatisk ved indtastning
Farv celler med formler blå
Tilpas sideopsætning
Første bogstav i celle med stort (Funktion)
Tælle, hver gang en bestemt celle aktiveres (Hændelse)
Makro til at sikre at en mappe altid åbes i Automatisk beregning (Hændelse)
Funktion til beregning af Rest af division (Funktion)
Arknavn i celle  (Funktion)
Indsæt tom række efter Subtotal

Opdel celleindhold i to (Funktion)
Find sidste forekomst af tegn i streng (Funktion)

Tæl forekomster af tegn i celle (Funktion)
Vis skjulte rækker i et bestemt område i alle ark med en bestemt navn
Sikre at et regneark først kan udskrives når bestemte celler er udfyldt
Beregn talværdi af en tekst (Funktion)
Tæl antal celler med tekst (Funktion)
Tæl celler med formler (Funktion)

Beregn den n'te rod af et tal  (Funktion)
Fyld tomme celler i markeret område
Skjul rækker på baggrund af celleindhold
Genveje til Fyld-kommandoen
Find alle priser fra given dato
Slet rækker med flettede celler
Udskrift en enkelt karakter
Kopier et område og indsæt det flere gange

Indsæt billeder med navne fra ark
Konverter til datoformat
Fyld celler nedad
Konverter tekst til tal og tal til tekst
Flyt mailadresser en kolonne til højre
Angiv Phi-værdien (Funktion)
Skjul rækker på betingelse af...
Flyt rækker til bunden
Find første bogstav i celle (Funktion)
Funktion til beregning af kvartal (Funktion)
Tæl hvor mange gange tallene skifter i en kolonne (Funktion)
Tæl antal bruge rækker og kopier data lige så langt
Udnyt statuslinjen i Excel i din kode
Sæt mærke i A-kolonnen, hvis B-kolonnen er udfyldt.
Oversæt formler til engelsk (Funktion)
Slet rækker i et ark på baggrund af data i andet ark
Er lige/Er ulige?  (Funktion)
Senest gemt  (Funktion)
Indsæt ny række i alle ark.
Fordel celleindhold i enkeltceller
Dele positive og negative tal i to kolonner
Find Kolonnebogstav. (Funktion)
Udskriv nummererede kopier
Korrekt ugenummer (Funktion)
Indsæt ugedagsnavn i celle (Funktion)
Beregn den reducerede tværsum af tal i celle (Funktion)
Beregn tværsum af tal i celle (Funktion)
Beregn sum af lige/ulige tal i område (funktioner)
Læg uger til ugenummer (funktion)
Husk adresse og vend tilbage til den senere
Vis en kædes reference (Funktion)
Undersøg om der er kæde i en celle
Navngiv fane på grundlag af celleindhold (Hændelse i Worksheet kodemodul.)
Gem mappe med navn fra celle

- Tilbage til makroer -

- Tilbage til Excel -

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

- Til top -

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

- Til top -

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

- Til top -

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

De to funktioner kan nu bruges sammen som følger:

=HVIS(erkaede(A1);viskaede(A1);"")

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

- Til top -

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.

Public glPlac As String 

Sub HerErJeg()
    glPlac = ActiveCell.Address
End Sub

Sub TilbageTilStart()
    Range(glPlac).Activate
End Sub

- Til top -

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

- Til top -

Beregn summen af alle lige hhv. ulige tal i et område

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

- Til top -

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

- Til top -

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.

Function RTSUM(ce As String) As Double
    Dim cif As Double
    Dim caf As Long
 

    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

- Til top -

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

- Til top -

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.

Function Arknavn()
     Arknavn = ActiveSheet.Name
End Function

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.

- Til top -

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.

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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

Funktionen bruges derefter som en helt almindelig funktion.

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

 

- Til top -

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

- Til top -

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:

c.ClearContents

- Til top -

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:

=SMALL(IF((A1:A6="Bil")*(B1:B6="Blå"),C1:C6),2)

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

- Til top - 

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

- Til top -

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".

Linjen

Application.Statusbar = Date

indsætter dags dato i statuslinjen.

Application.Statusbar = ActiveWorkbook.FullName

indsætter navnet på den aktive projektmappe.

Application.StatusBar = Sheets(1).Range("a1")

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

For at komme tilbage til "standard" bruges

Application.StatusBar = False

- Til top -

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

- Til top -

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.

- Til top -

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:

Function Kvartal(cel)
    Kvartal = Format(cel, "q")
End Function

- Til top -

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.

- Til top -

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

- Til top -

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.

Function PHI() As String
    PHI = (1 + Sqr(5)) / 2
End Function

- Til top -

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

- Til top -

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

- Til top -

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

Begge makroerne virker på de celler, der er markerede, når makroen afspilles.

- Til top -

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.

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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


- Til top -

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.

Sub FyldHoejre()
    Selection.FillRight
End Sub

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

- Til top -

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.

- Til top -

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

- Til top -

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.

Function NROD(tal, rod)
    NROD = tal ^ (1 / rod)
End Function

- Til top -

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

- Til top -

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

- Til top -
 

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

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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.

- Til top -

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

- Til top -

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.

Private Sub Workbook_Open()
    Application.Calculation = xlAutomatic
End Sub

- Til top -

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

- Til top -

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

- Til top -

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

- Til top -

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.

- Til top -

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

- Til top -

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

- Til top -

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.

 

- Til top -
- Tilbage til makroer -
- Tilbage til Excel -