Småmakroer
Følgende side er lånt fra Jan Kronsells hjemmeside
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 -
|