Här kan du hitta VBA-kod för olika ändamål. Koden är fri att kopiera och använda.

Funktionsmakron

• Konvertera romerska bokstäver till numeriska tal

• Plocka ut ett tal ur en sträng

• Konvertera felaktiga datumformat

• Extrahera tal ur en blandad sträng

• Ta reda på viket datum påskdagen infaller

• Visa vilken cellreferens som innehåller ett visst värde.

• Visa kalkylbladsnamn

• Hämta samtliga tal ur en sträng med både text och tal  

• Funktion som visar en formels konstanter i en enkel beräkning

• Funktion som visar månadsnamnet utifrån månadsnummer  

• Funktion som skapar en förkortning av innehållet i en cell

• Funktion som kastar om innehållet i en cell  

• Funktion som testar om ett tal är ett primtal

• Funktion som vänder på innehållet i en cell

• Funktion som visar formatet i en cell  

• Funktion som refererar till cell i föregående eller nästa blad

• Funktion som avrundar till närmaste 25-öring

• Summera alla separata siffror i en blandad sträng

Procedurmakron

• Skapa dynamiska områden när du använder Avancerat filter

• Enklare sätt att referera till celler i VBA

• Förhindra användare att Spara som

• Skapa adressetiketter från en adresslista

• Skapa en Power Point-presentation  från Excel

• Kontrollera ett diagrams egenskaper från kalkylbladet

• Visa aktiv cell tydligare

• Ta reda på vad som finns i din dator

• Spara en fil med dagens datum i filnamnet

• Lås arbetsytan för användaren

• Färga alla celler som innehåller en viss text

• Skapa en tabell i HTML-format

• Lista alla referenser som finns i ett VBA-projekt

• Förstora en utskrift till en sida

• Öppna textfiler med VBA

• Sortera en kolumn efter färger

• Använd funktionen IIF som alternativ till IF 

• Visa en cell föregående värde i en kommentar

• Sök efter ett ord eller fras i hela arbetsboken

• Visa när och av vem en cell ändrades i en kommentar

• Markera alla upplåsta celler

• Flytta markören med VBA

• Skriv ut annorlunda sidfot

• Matcha två kolumner och leta upp saknade data

• Kopiera endast synliga celler med kortkommando

• Visa formler med en VBA-funktion

• Dölj blad så att de inte kan tas fram via menyn Format - Blad

• Skriv ut lista på celler med villkorsstyrd formatering och dataverifiering

• Ändra teckenstorlek på befintliga kommentarer

• Avbryt med ESC eller Ctrl-Break utan hamna i avbrottsläge

• Undvik dialogrutan Uppdatera länkar

• Korrigera felaktigt antal sidor vid utskrift  

• Återställ sista använda cell

• Visa låsta celler med en kommentar

• Konvertera absolut referens till Relativ och v/v 

• Använd ADO för extern datahämtning

• Skapa slumptal

• Radera rader som uppfyller ett villkor  

• Konvertera plusvärden till minusvärden och vice versa  

• Räkna överordnade och underordnade celler  

• Visa information om din skrivare

• Visa systeminformation om din dator

• Skriv ut alla kalkylbladsformler i ett Worddokument 

• Skapa en lista över alla kommentarer i ett kalkylblad  

• Sortera bladflikar i bokstavsordning

• Dela upp en lång kolumn i flera kortare

• Kontrollera om ett ISBN-nummer är korrekt

• Kontrollera personnummer

• Slumpa lösenord

• Infoga egna menyer  

• Infoga egna menyer med undermenyer

• Skapa snabbmenyer

• Skiftlägesväxlingsfunktion

• Skydda alla blad

• Loopa igenom alla filer i en specifik mapp

• Radera dubletter i kolumn A

• Radera dubletter i kolumn A, B och C

• Radera tomma rader

• Skriv lösenord till Registry

• Spela ljudfiler

• Skapa en lista över filer och filinformation i en viss mapp med undermappar

• Radera modul i VB-projekt

• Aktivera WinZip från Excel

• Visa alla namngivna celler

• Visa när och vem som öppnade filen senast

• Visa en lista över alla teckensnitt i datorn

• Exportera lista till nytt Word-dokument

• Exportera lista till befintligt Word-dokument och klistra in sist i dokumentet.

• Programmera assistenten

• Låt assistenten berätta vilka frågor som finns i en Access-databas

• Exportera data till en tabell i en Access-databas

• Öppna ett formulär i en Access-databas

• Skapa tolv blad med månadernas namn

• Skicka mail med bifogad fil

• Visa innehållet i Outlooks Inbox i ett kalkylblad

• Skapa en ny mapp med VBA

• API-funktion som kan visa hur länge datorn varit påslagen

Om du vill att en meny ska infogas när en fil öppnas och försvinna när filen stängs så har du  exempelkod här

Sub Auto_Open()
Dim minMeny As CommandBar
On Error Resume Next
With Application.CommandBars.ActiveMenuBar
    .Visible = True
        With .Controls
            With .Add(msoControlPopup)
                .Caption = "&Makron"
                    With .Controls
                        With .Add(msoControlButton)
                            .Caption = "Kent testar"
                            .OnAction = "KörMakro"
                               End With

                               With .Add(msoControlButton)
                                .Caption = "Kent testar2"
                                .OnAction = "KörMakro2"
                                   End With

                                With .Add(msoControlButton)
                                .Caption = "Kent testar3"
                                .OnAction = "KörMakro3"
                                End With

                           End With
                      End With
                End With
       End With

End Sub

Sub KörMakro()
MsgBox "Det fungerar"
End Sub

Sub KörMakro2()
MsgBox "Det fungerar även här"
End Sub
Sub KörMakro3()
MsgBox "Det fungerar även här den tredje gången"
End Sub



Sub Auto_Close()
Application.CommandBars.ActiveMenuBar.Controls("&Makron").Delete
End Sub

Om du vill att en meny med undermenyer ska infogas när en fil öppnas och försvinna när filen stängs så har du  ett exempel här.

Sub Auto_Open()
 

On Error Resume Next
 

With Application.CommandBars.ActiveMenuBar
    .Visible = True
        With .Controls
 

'Argument för huvudmenyn. Eftersom det är den första blir den huvudmeny
        With .Add(msoControlPopup)
            .Caption = "&Makron" ' Namn på huvudmenyn
 

'********Här kommer koden för undermenyerna*********'
            With .Controls
 

'****Argument för att skapa en undermeny med flera undermenyer****
            With .Add(msoControlPopup)
 

'****Namn på den första undermenyn********
                .Caption = "Kent testar"
 

'****Lägg till tre undermenyer till den "Kent testar"*******
            With .Controls.Add(msoControlButton)
 

'****Namn på den första undermenyn*************
                .Caption = "Kent testar Kort"
 

'****Procedur som körs vid klick på första undermenyn*****
                .OnAction = "KörMakroKort"
 

            End With
            With .Controls.Add(msoControlButton)
                .Caption = "Kent testar Mellan"
                .OnAction = "KörMakroMellan"
            End With
            With .Controls.Add(msoControlButton)
                .Caption = "Kent testar Lång"
                .OnAction = "KörMakroLång"
            End With
 

'*******Här slutar koden för de tre undermenyerna*******
        End With
 

'*****Här är de sista två menyerna*********
           

With .Add(msoControlButton) 'Argument för vanlig meny
                .Caption = "KörMakro2" 'Namn på den vanliga menyn
                .OnAction = "KörMakro2" 'Procedur som körs vid klick
            End With

            With .Add(msoControlButton)
                .Caption = "KörMakro3"
                .OnAction = "KörMakro3"
            End With
 

'*****Slut sista två*************
            End With
        End With
    End With
End With
End Sub

Sub KörMakroKort()
MsgBox "Nu körs Makro kort"
End Sub

Sub KörMakroMellan()
MsgBox "Nu körs Makro mellan"
End Sub

Sub KörMakroLång()
MsgBox "Nu körs Makro lång"
End Sub

Sub KörMakro2()
MsgBox "Nu körs makro 2"
End Sub

Sub KörMakro3()
MsgBox "Nu körs makro 3"
End Sub

Sub Auto_Close()
'Radera hela menyn när filen stängs
Application.CommandBars.ActiveMenuBar.Controls("&Makron").Delete
End Sub

Skydda alla blad i arbetsboken

Sub SkyddaBlad()
Dim intBlad As Integer
    For intBlad = 1 To Sheets.Count
        Sheets(intBlad).Protect    
    Next
End Sub

Om du vill ha en skiftlägesväxlings-funktion i Excel

Sub Auto_Open()
Application.OnKey ("{F10}"), "Change"
End Sub

Sub change()
Dim Cell As Range
    For Each Cell In Selection
        If Cell = UCase(Cell) Then
            Cell = StrConv(Cell, vbProperCase)
        Else
            Cell = UCase(Cell)
        End If
    Next
End Sub

Kontrollera om ett personnummer är korrekt

Option Explicit

Sub Kontroll()
Dim Pnr As String
Dim Testnr As String
Dim Kontrollsumma As Integer
Dim Subtotal As Integer
Dim resten As Integer
Dim kSiffra As Integer
Dim omr As Range
Dim I
Dim X As Integer
Dim persnr As String

Set omr = Application.Intersect(Range(ActiveCell.Address), Range("pnr"))
persnr = InputBox("Ange ditt personnummer")
Range("c8").Select
ActiveCell.Formula = persnr
If Not omr Is Nothing Then
    Pnr = ActiveCell.Value
End If
If (Len(Pnr) <> 11 Or InStr(Pnr, "-") <> 7) Then
    OgiltigtPnr (" Skriv i formatet 550101-0101")
End If
Testnr = Left(Pnr, 6) & Mid(Pnr, 8, 3)
Kontrollsumma = 0

For I = 1 To 9 Step 2
    X = 2 * Val(Mid(Testnr, I, 1))
        If X >= 10 Then
            Subtotal = 1 + X - 10
        Else
            Subtotal = X
        End If
Kontrollsumma = Kontrollsumma + Subtotal
Next I

For I = 2 To 8 Step 2
    Subtotal = Val(Mid(Testnr, I, 1))
    Kontrollsumma = Kontrollsumma + Subtotal
Next I
resten = Kontrollsumma Mod 10
If resten = 0 Then
    kSiffra = 0
Else
    kSiffra = 10 - resten
End If

If kSiffra <> Val(Right(Pnr, 1)) Then
    OgiltigtPnr ("Kontrollsiffran räknades ut till " & Str(kSiffra))
End If
End Sub



Sub OgiltigtPnr(feltyp As String)
Dim I As Integer
Dim persnr As String
ActiveCell.Clear
For I = 1 To 100
    Beep
Next
MsgBox ("Ogiltigt personnummer! Börja om!") & " " & feltyp
ActiveCell.Clear
persnr = InputBox("Ange ditt personnummer")
Range("c8").Select
ActiveCell.Formula = persnr
End
End Sub

Sub Auto_Open()
    ThisWorkbook.Sheets("Register").OnEntry = "Kontroll"
End Sub

Slumpa fram ett lösenord

Option Explicit

Public Function SlumpaPassWord(intLen As Integer, bolAlternativ As Boolean) As String
Dim lngPos As Long
Dim intTecken As Integer
Dim strResultat As String

On Error GoTo Felhantering

If intLen Then
    Randomize Timer
    For lngPos = 1 To intLen
        If bolAlternativ Then
        If lngPos Mod 2 Then
            intTecken = Int((31 * Rnd) + 6)
        Else
            intTecken = Int((5 * Rnd) + 1)
        End If
    Else
    intTecken = Int((38 * Rnd) + 1)
    End If
strResultat = strResultat & Mid$("67890AEIOUBCDFGHJKLMNPQRSTVWXYZÅÄÖ12345", intTecken, 1)
Next lngPos
End If

SlumpaPassWord = strResultat

Avsluta:
Exit Function

Felhantering:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SlumpaPassWord"
Resume Avsluta

End Function


Sub pw()
Dim antal As Integer
antal = InputBox("Hur många tecken vill du ha i ditt password?", "Lösenord")
MsgBox "Ditt nya lösenord är : " & SlumpaPassWord(antal, True), vbInformation, "Lösenord"
End Sub

Loopa igenom alla filer i en specifik mapp

Option Explicit

Sub LoopaIgenomMapp()
Dim strBook As String, strDir As String, strSpec As String
Dim objBook As Object

strDir = InputBox("Skriv in sökväg")
strSpec = "*.xls"
strBook = Dir(strDir & "\" & strSpec)

Do Until strBook = ""
    Set objBook = Workbooks.Open(strDir & "\" & strBook)

    ' Din instruktion

    objBook.Close savechanges:=True
    MsgBox strBook
    strBook = Dir()
Loop


End Sub

Radera de rader där dubletter förekommer i kolumn A

Sub RaderaDublettrader()

Dim intCol As Integer
Dim lngRadAntal As Long
Dim varValue As Variant
Dim Rng As Range

'**************Variabeldeklarationer***********************

On Error GoTo Felhanteraren
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range("A1").Select
intCol = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

For lngRadAntal = Rng.Rows.Count To 1 Step -1
varValue = Rng.Cells(lngRadAntal, 1).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(1), varValue) > 1 Then
Rng.Rows(lngRadAntal).EntireRow.Delete
End If
Next lngRadAntal

Felhanteraren:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Radera de rader där dubletter förekommer i kolumn A,B och C

Public Sub RaderaDubletterITreKolumner()
Dim intKolumn As Integer
Dim lngRader As Long
Dim lngRäknare As Long
Dim Kol1 As Variant, Kol2 As Variant, Kol3 As Variant
Dim rngKontrollOmråde As Range
Dim x As Integer
Dim strTestNamn As String

On Error GoTo Felhantering
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range("A1").Select
intKolumn = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set rngKontrollOmråde = Selection
Else
Set rngKontrollOmråde = ActiveSheet.UsedRange.Rows
End If

lngRäknare = 0
For lngRader = rngKontrollOmråde.Rows.Count To 1 Step -1
Kol1 = rngKontrollOmråde.Cells(lngRader, 1)
Kol2 = rngKontrollOmråde.Cells(lngRader, 2)
Kol3 = rngKontrollOmråde.Cells(lngRader, 3)
strTestNamn = Kol1 & Kol2 & Kol3
x = Application.WorksheetFunction.CountIf(rngKontrollOmråde.Columns(1), Kol1)
y = Application.WorksheetFunction.CountIf(rngKontrollOmråde.Columns(2), Kol2)
z = Application.WorksheetFunction.CountIf(rngKontrollOmråde.Columns(3), Kol3)
Application.StatusBar = "Utvärderar post nr " & lngRader
If x > 1 And y > 1 And z > 1 Then
rngKontrollOmråde.Rows(lngRader).EntireRow.Delete
lngRäknare = lngRäknare + 1
End If
Next lngRader
Application.StatusBar = "Klar"
Felhantering:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Radera tomma rader 

Sub RaderaTommaRader()

Dim lngAntalRader As Long

'*********************************************

Selection.SpecialCells(xlCellTypeLastCell).Select

lngAntalRader = Selection.Row

For i = 1 To lngAntalRader

   If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then

   Rows(i).Delete

End If

Next

End Sub

Skriv lösenord till Registry och kontrollera om lösenordet är korrekt.

Public strPassword As String

Sub PassWord()
strPassword = InputBox("Set password")
SaveSetting "Excel", "Protection", "PW", strPassword
End Sub


Sub OpenPassword()
Dim strÄndra As String, strPWCheck As String, strPWInput As String

strPWCheck = GetSetting("Excel", "Protection", "PW")
Igen:

strPWInput = InputBox("Ange lösenord")
If strPWInput = strPWCheck Then
MsgBox "Password korrekt"
strPassword = InputBox("Set new password")
SaveSetting "Excel", "Protection", "PW", strPassword
ElseIf MsgBox("Felaktigt lösenord. Vill du föröska igen?", vbYesNo, _ "Password") = vbYes Then
GoTo Igen
End If
End Sub

Spela upp ljudfiler (.wav) i Excel. 

För att det ska fungera krävs att du använder API funktionerna som finns deklarerade.

Ladda hem en Word-fil med en beskrivning av funktionen sndPlaySound

Public Declare Function sndPlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long


Sub SpelaWavFil(WavFileName As String, Wait As Boolean)
    If Dir(WavFileName) = "" Then Exit Sub
    sndPlaySound WavFileName, 1
End Sub


Sub SpelaUppWavFil()
    SpelaWavFil "c:\windows\media\tada.wav", False
End Sub

Skapa en lista över filer och filinformation i en viss mapp med undermappar. 

Resultatet visas i kalkylbladet. För att denna kod ska fungera krävs att du lägger till referensbiblioteket Microsoft Scripting Runtime via menyn Verktyg - Referenser i Visual Basic Editorn

Sub TestListFilesInFolder()
Dim strMapp As String
Workbooks.Add
strMapp = InputBox("Ange mapp för sökning av filer")
    With Range("A1")
        .Value = "Mapp innehåll"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A2") = "Filnamn"
    Range("B2") = "Filstorlek"
    Range("C2") = "Filtyp"
    Range("D2") = "Skapad"
    Range("E2") = "Senast använd"
    Range("F2") = "Senast ändrad:"
    Range("G2") = "Attribut"
    Range("H2") = "Dosnamn:"
    Range("A2:H2").Font.Bold = True
    ListFilesInFolder strMapp, True 
End Sub

Sub ListFilesInFolder(SourceFolderName As String,         IncludeSubfolders As Boolean)

    Dim FSO As Scripting.FileSystemObject
    Dim fldMapp As Scripting.Folder, fldUnderMapp As Scripting.Folder
    Dim Fil As Scripting.File
    Dim lngRad As Long

    Set FSO = New Scripting.FileSystemObject
    Set fldMapp = FSO.GetFolder(SourceFolderName)
    lngRad = Range("A65536").End(xlUp).Row + 1
For Each Fil In fldMapp.Files
    Cells(lngRad, 1) = Fil.path
    Cells(lngRad, 2) = Format(Fil.Size, "# ##") & " byte"
    Cells(lngRad, 3) = Fil.Type
    Cells(lngRad, 4) = Fil.DateCreated
    Cells(lngRad, 5) = Fil.DateLastAccessed
    Cells(lngRad, 6) = Fil.DateLastModified
    Cells(lngRad, 7) = Fil.Attributes
    Cells(lngRad, 8) = Fil.ShortPath

    lngRad = lngRad + 1
Next Fil
    If IncludeSubfolders Then
         For Each fldUnderMapp In fldMapp.SubFolders
            ListFilesInFolder fldUnderMapp.path, True
         Next fldUnderMapp
    End If
Columns("A:H").AutoFit
Set Fil = Nothing
Set fldMapp = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub

Radera modul i VB-projekt. Nedanstående kod raderar Modul2 i den aktiva arbetsboken.

Sub RaderaModul2()
Dim vbComp As Object
    Set vbComp = ActiveWorkbook.VBProject.VBComponents
    With vbComp
        .Remove vbComp("Modul2")
    End With
End Sub

Funktionen refererar till en cell på föregående eller nästa blad. Ange -1 som för argumentet Blad om du referar till föregående och 1 om du refererar till nästa blad.

Ex:: =NästaBlad(-1;B1) referar till cell B1 på föregående blad.

Function NästaBlad(Blad, Cell)

Dim WBook As Workbook
Dim WksCount As Integer, i As Integer
Dim CallerSheet As String, CallerIndex As Integer
Application.Volatile

Set WBook = Application.Caller.Parent.Parent
Dim Wks() As Worksheet
WksCount = 0
For i = 1 To WBook.Sheets.Count
    If TypeName(WBook.Sheets(i)) = "Worksheet" Then
        WksCount = WksCount + 1
        ReDim Preserve Wks(1 To WksCount)
        Set Wks(WksCount) = WBook.Sheets(i)
    End If
Next i

CallerSheet = Application.Caller.Parent.Name
For i = 1 To UBound(Wks)
    If CallerSheet = Wks(i).Name Then CallerIndex = i
Next i

NästaBlad = Wks(CallerIndex + _
Blad).Range(Cell.Address)
End Function

Avrunda decimaler.

Denna funktion avrundar tal med decimaler under 25 till 0 (Närmaste lägre heltal), decimaler större än 25 och 75 till 0,50 samt decimaler större än 75 till 1 (Närmaste högre heltal).

Function Öresavrundning(Tal As Single) As Single
Dim intLangd As Integer
Dim intKomma As Integer


intLangd = Len(Tal)
intKomma = InStr(Tal, ",")
If intKomma = 0 Then Öresavrundning = Tal
sngRundaTal = Val(Right(Tal, 2))

If sngRundaTal >= 75 Then
    Öresavrundning = Application.WorksheetFunction.Ceiling(Tal, 1)
ElseIf sngRundaTal >= 50 Then
    Öresavrundning = Application.WorksheetFunction.Floor(Tal, 0.5)
ElseIf sngRundaTal >= 25 Then
    Öresavrundning = Application.WorksheetFunction.Ceiling(Tal, 0.5)
ElseIf sngRundaTal <= 25 Then
    Öresavrundning = Application.WorksheetFunction.Floor(Tal, 1)
End If
End Function

Med följande kod kan du aktivera andra Windowsprogram från Excel. I exemplet öppnas Winzip

Sub AktiveraWinZip()

Dim strWinZipApp As String, strWinZipPath As String, varProc As Variant

strWinZipApp = "WinZip"

strWinZipPath = "C:\Program Files\WinZip\WINZIP32.EXE"

On Error GoTo Felhantering:

AppActivate strWinZipApp

Exit Sub

Felhantering:

If MsgBox(strWinZipApp & " är inte aktivt. Vill du starta programmet?", _

vbYesNo + vbQuestion) = vbYes Then _

varProc = Shell(strWinZipPath, 1)

End Sub

Om du snabbt och enkelt vill se alla namngivna celler eller radera alla namn kan du använda följande kod:

Sub VisaNamngivnaCeller()

Dim Namn As Name

For Each Namn In ThisWorkbook.Names

With Namn

If MsgBox("Vill du radera " & .Name & " ? " & vbCrLf & _

"Refererar till " & .RefersTo, vbYesNo + vbQuestion) = vbYes

Then _

.Delete

End With

Next

End Sub

Om du arbetar på ett nätverk kan det vara intressant att veta när en fil senast uppdaterades och av vem. 

Informationen lagras i Registret i följande mapp:
HKEY_CURRENT_USER\Software\VB and VBA Program Settings 
Nedanstående kod sköter detta åt dig.

Sub Auto_Open()
Dim lngRäknare As Long, strSenastÖppnad As String
Dim strMeddelande As String, strSenastAnvänd As String

'Hämtar data från Registry
lngRäknare = GetSetting("Filinformation", "Fildata", "Antal", 0)
strSenastÖppnad = GetSetting("Filinformation", "Fildata", "Öppnad", "")
strSenastAnvänd = GetSetting("Filinformation", "Fildata", "Använd", "")
'Visa information i messagebox
strMeddelande = "Den här filen är öppnad " & lngRäknare & " gånger."
strMeddelande = strMeddelande & vbNewLine & "Filen var senast öppnad: " _
& strSenastÖppnad
strMeddelande = strMeddelande & vbNewLine & "Filen användes senast av " _
& strSenastAnvänd

MsgBox strMeddelande, vbInformation, ThisWorkbook.Name

'Uppdatera informationen och lagra den nya
lngRäknare = lngRäknare + 1
strSenastÖppnad = Date & " " & Time
strSenastAnvänd = Application.UserName

SaveSetting "Filinformation", "Fildata", "Antal", lngRäknare
SaveSetting "Filinformation", "Fildata", "Öppnad", strSenastÖppnad
SaveSetting "Filinformation", "Fildata", "Använd", strSenastAnvänd

End Sub

Visa datorns alla teckensnitt i kolumn A.

Sub VisaTeckenLista()

Dim intRadnr As Integer, Teckenlista As Object

Set Teckenlista = Application.CommandBars("Formatting").FindControl(Id:=1728)

On Error Resume Next

Range("A:A").ClearContents

For intRadnr = 0 To Teckenlista.ListCount - 1

    With Cells(intRadnr + 1, 1)

    .Value = Teckenlista.List(intRadnr + 1)

    .Font.Name = Teckenlista.List(intRadnr + 1)

End With

Next

End Sub

Exportera ett listområde till ett nytt Worddokument och spara detta

Sub SendRangeToWord()
Dim myWord As Object, strFilename As String
Set myWord = CreateObject("Word.Application")
strFilename = "C:\tmp\Test.doc"
Range("A1:D20").Copy

With myWord
    .Documents.Add
    .Selection.Paste
    .ActiveDocument.SaveAs strFilename
    .Application.Quit
End With
Set myWord = Nothing
End Sub

Exportera ett listområde till ett befintligt  Worddokument och klistra in sist i dokumentet samt spara ändringar.

Sub ExportToWord()
Dim myWord As Object, strFilename As String
Set myWord = CreateObject("Word.Application")
strFilename = "C:\tmp\Test.doc"
Range("A1:D20").Copy

With myWord
    .Documents.Open strFilename
        With .Selection
            .EndKey Unit:=wdStory
            .TypeParagraph
            .Paste
        End With
    .ActiveDocument.Save
    .Application.Quit
End With
Set myWord = Nothing
End Sub

Programmera assistenten

Här är ett exempel på hur du kan låta assistenten dyka upp när en fil öppnas och tal om datum och klockslag.  

OBS! Blanksteg följt av _ (underscore) betyder radbrytning i koden.

OBS! vbCrLf betyder radbrytning i meddelanderutan. Kan bytas ut  mot vbNewLine

Sub Auto_Open()
    With Assistant
        .Visible = True
        .Sounds = True
        .Animation = msoAnimationGetAttentionMajor
    End With
With Assistant.NewBalloon
        .Heading = "God morgon"
        .Text = "Hej!!" & vbCrLf & "I dag är det " _

        & Date & vbCrLf & "Klockan är " & Time
        .Show
        .Animation = msoAnimationBeginSpeaking
    End With
End Sub

---

Låt assistenten berätta vilka frågor som finns i en Accessdatabas

I detta exempel visar assistenten vilka frågor som i finns i exempeldatabasen Northwind. 
OBS! Kontrollera sökvägen.

Sub VisaFrågor()

Dim Databasen As Database
Dim Poster As Recordset
Dim strFält As String
Dim fråga As QueryDef
Dim strFråga As String
Application.ScreenUpdating = False


Set Databasen = OpenDatabase("C:\Program\MSOffice\Northwind.mdb")

For Each fråga In Databasen.QueryDefs
    strFråga = Left(fråga.Name, 3)
    If strFråga = "qry" Then
        strFält = strFält & vbCrLf & fråga.Name
    End If
Next

Databasen.Close
    With Assistant
        .Visible = True
        .Sounds = True
        .Animation = msoAnimationThinking
    End With
With Assistant.NewBalloon
        .Heading = "Följande frågor finns"
        .Text = strFält
        .Show
        .Animation = msoAnimationGetWizardy
End With

End Sub

---

Exportera data till en tabell i en Accessdatabas. 

I detta fall exporteras området A1:E9 i ett kalkylblad till tabellen Publishers i databasen STATEUBOOKSTORE.MDB från Excelfilen DaoTest.xls. 
Excelfilen måste vara i tabellform med samma fältnamn som i Accessdatabasen.

Sub SendData()
Dim myDb As Object
Dim strPath As String, strMyFile As String

strPath = "C:\STATEUBOOKSTORE.MDB" 'your Accessfile
strMyFile = "C:\DaoTest.xls" 'your Excelfile

Set myDb = CreateObject("Access.Application")
With myDb
.OpenCurrentDatabase strPath
.DoCmd.TransferSpreadsheet acImport, 8, "Publishers", strMyFile, True, "A1:E9"
End With

Set myDb = Nothing
End Sub

Öppna ett formulär i en Accessdatabas. Ändra till korrekt sökväg och formulärnamn

Sub OpenForm()
Dim myDb As Object
Dim strPath As String

strPath = "C:\MyDatabase.MDB" 'your Accessfile
Set myDb = CreateObject("Access.Application")
Access.Application.Visible = True
With myDb
    .OpenCurrentDatabase strPath
    .DoCmd.OpenForm "Publishers"
    .Visible = True
End With
End Sub

Skapa tolv blad i en arbetsbok med månadernas namn på bladflikarna

Om det finns mer än tolv blad raderas dessa.

Sub InfogaNamn()

Dim intBlad As Integer

Dim intNya As Integer, i As Integer

Application.ScreenUpdating = False

intBlad = Sheets.Count

intNya = intBlad + 1

'Om antalet blad överstiger 12 ska dessa raderas

If intBlad > 12 Then

    For i = 13 To intBlad

        On Error Resume Next

        Application.DisplayAlerts = False

        Sheets(i).Delete

    Next

End If

'Om antalet blad understiger 12 lägger vi till det antal som behövs

For i = intNya To 12

    Sheets.Add

Next

Range("A1") = "Jan"

Range("A1").AutoFill Range("A1:A12")

For i = 1 To 12

Sheets(i).Name = Range("A" & i)

Next

Range("A1:A12").ClearContents

Sheets(1).Activate

End Sub

Skicka mail med bifogad fil från Excel. I detta exempel bifogas filen test.xls.

Sub SendFile()
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
Dim myAttachments As Variant

On Error Resume Next
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add "C:\tmp\test.xls"

With myItem
.Subject = "Skickar fil"
.Body = "Hej. Här kommer filen."
.To = "schederin@home.se"
.Attachments = myAttachments
.Send
End With

Set myOlApp = Nothing

End Sub

Visa innehållet i Outlooks Inbox i ett kalkylblad

Option Explicit

Sub VisaInbox()
Dim OLF As Outlook.MAPIFolder
Dim intEPostAntal As Integer, i As Integer, intEPostKonto As Integer
Application.ScreenUpdating = False
Workbooks.Add

Cells(1, 1).Value = "Ämne"
Cells(1, 2).Value = "Mottaget"
Cells(1, 3).Value = "Från"
Cells(1, 4).Value = "Läst"
Cells(1, 5).Value = "Bifogade filer"
With Range("A1:E1").Font
    .Bold = True
    .Size = 11
End With
Application.Calculation = xlCalculationManual
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
intEPostAntal = OLF.Items.Count
i = 0: intEPostKonto = 0
While i < intEPostAntal
    i = i + 1
Application.StatusBar = "Läser E-postmeddelande " & _

Format(i /         intEPostAntal, "0%") & "..."
With OLF.Items(i)
    intEPostKonto = intEPostKonto + 1
    Cells(intEPostKonto + 1, 1).Value = .Subject
    Cells(intEPostKonto + 1, 2).Value = .ReceivedTime
    Cells(intEPostKonto + 1, 3).Value = .SenderName
    Cells(intEPostKonto + 1, 4).Value = Not .UnRead
    Cells(intEPostKonto + 1, 5).Value = .Attachments.Count
End With
Wend
Application.Calculation = xlCalculationAutomatic
Set OLF = Nothing
Columns("A:D").AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveWorkbook.Saved = True
Application.StatusBar = False
End Sub

Skapa en ny mapp med VBA. Följande lilla snutt är ett exempel på hur du kan skapa en ny mapp via VBA-kod.

Sub SkapaMapp()

Dim strMinMapp As String

strMinMapp = "C:\ABCDKent"

MkDir strMinMapp

End Sub

API-funktion som kan visa hur länge datorn varit påslagen

Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub VisaStats()
Dim lngTickCount As Long
lngTickCount = GetTickCount
MsgBox ("Du har använt din dator i:" & vbNewLine & " * " & CStr(lngTickCount) & _
" millisekunder, eller" & _
vbNewLine & " * " & CStr(Round(lngTickCount / 1000)) & " sekunder, eller" & _
vbNewLine & " * " & CStr(Round((lngTickCount / 1000) / 60)) & " minuter")
End Sub

Funktion som testar om ett tal är ett primtal

Function Primtal(Tal As Long)

Dim lngAntal As Long

Dim lngHalva As Long

lngHalva = Tal / 2 + 1

For lngAntal = 2 To lngHalva

   If (Tal Mod lngAntal) = 0 Then

     Primtal = ""

     Exit Function

   End If

Next

Primtal = "Primtal"

End Function

Funktion som vänder på innehållet i en cell

Function VändText(Text As String) As String
Dim intLängd As Integer, i As Integer
Dim strVändText As String
    'Ta reda på antal tecken i strängen
    intLängd = Len(Text)
    'Loopa bakåt från sista bokstaven i strängen
    For i = intLängd To 1 Step -1
        'Hämta ett tecken i taget från slutet
        strVändText = Mid(Text, i, 1)
        'Sammanfoga strängen
        VändText = VändText & strVändText
    Next
End Function

Funktion som visar formatet i en cell

Function VisaFormat(Cell)
   Application.Volatile True
   VisaFormat = Cell.NumberFormat
End Function

Funktion som kastar om innehållet  i en cell

Function KastaOmText(Text As String) As String

Dim intTextLängd As Integer
Dim i As Integer
Dim intSlumpTal As Integer
Dim strTecken As String * 1
intTextLängd = Len(Text)
For i = 1 To intTextLängd
    strTecken = Mid(Text, i, 1)
    intSlumpTal = Int((intTextLängd - 1 + 1) * Rnd + 1)
    Mid(Text, i, 1) = Mid(Text, intSlumpTal, 1)
    Mid(Text, intSlumpTal, 1) = strTecken
Next i
KastaOmText = Text
End Function

Funktion som skapar en förkortning av innehållet i en cell

Function Förkortning(Text As String) As String

Dim TextLen As Integer
Dim i As Integer
Text = Application.Trim(Text)
TextLen = Len(Text)
Förkortning = Left(Text, 1)
For i = 2 To TextLen
    If Mid(Text, i, 1) = Chr(32) Then
        Förkortning = Förkortning & Mid(Text, i + 1, 1)
    End If
Next i
Förkortning = UCase(Förkortning)
End Function

Procedur som kontrollerar om ett ISBN-nummer i den aktiva cellen är korrekt

Sub ISBNKontroll()
Dim strKontroll As String, strKontroll1 As String, strKontroll2 As String
Dim strMsg1 As String, strMsg2 As String, strMsg3 As String
Dim Ix, intRäknare As Integer, intAntalTecken As Integer

strKontroll = ActiveCell
Ix = 1
intRäknare = 1
Do While Ix <> 0
strKontroll1 = Mid(strKontroll, intRäknare, 1)
Select Case strKontroll1
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
strKontroll2 = strKontroll2 + strKontroll1
Case "X", "x"
If Len(strKontroll2) = 9 Then
strKontroll2 = strKontroll2 + strKontroll1
Else
strMsg3 = """X"" måste stå sist, och antal tecken undantaget ""-"" måste vara 10!"
MsgBox (strMsg3)
Exit Sub
End If
Case "-"
Case ""
Exit Do

Case Else
strMsg1 = "Felaktigt tecken: " & """" & strKontroll1 & """. Ett ISBN-nummer skrivs med siffror, ""-"" samt eventuellt ""X""."
MsgBox (strMsg1)
Exit Sub
End Select
intRäknare = intRäknare + 1
Loop
intAntalTecken = Len(strKontroll2)
If intAntalTecken <> 10 Then
strMsg2 = "Du har skrivit " & intAntalTecken & " tecken (förutom ""-""). Ett ISBN måste innehålla 10 tecken!"
MsgBox (strMsg2)
End If
TestaSistaTecken (strKontroll2)
End Sub

Function TestaSistaTecken(CheckISBN)
Dim strKontroll As String, strKontrollTecken As String, intKontrollSiffra As Integer
Dim intTest As Integer, intTest1 As Integer, intTest2 As Integer
Dim intFaktor As Integer, i As Integer
strKontroll = CheckISBN
intFaktor = 10
For i = 1 To (Len(strKontroll) - 1)
intTest = Val(Mid(strKontroll, i, 1) * intFaktor)
intTest1 = intTest1 + intTest
intFaktor = intFaktor - 1
Next
strKontrollTecken = Right(strKontroll, 1)
If strKontrollTecken = "X" Or strKontrollTecken = "x" Then
intKontrollSiffra = 10
Else
intKontrollSiffra = Val(strKontrollTecken)
End If
intTest2 = 11 - (intTest1 Mod 11)
If intTest2 = intKontrollSiffra Then
MsgBox "Kontrolltecknet " & strKontrollTecken & " är korrekt!"
ElseIf intTest2 = 10 Then
MsgBox ("Fel kontrolltecken! Skall vara: X")
Else
MsgBox ("Fel kontrolltecken! Skall vara: " & intTest2)
End If
End Function

Dela upp en lång kolumn i flera mindre

Anta att du har en kolumn som är flera tusen rader lång och du vill dela upp den på fyra mindre kolumner. Denna procedur fixar det åt dig.

Sub RowToColumn()
Dim lngFirstRow As Long, lngLastRow As Long, lngPasteRow As Long
Application.ScreenUpdating = False
lngLastRow = 4
lngPasteRow = 1
For lngFirstRow = 1 To Range("A65000").End(xlUp).Row Step 4
   Range("A" & lngFirstRow & ":" & "A" & lngLastRow).Copy
   Cells(lngPasteRow, 2).Select
   Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
   , Transpose:=True
   Range("A" & lngFirstRow & ":" & "A" & lngLastRow).ClearContents
   lngLastRow = lngLastRow + 4
   lngPasteRow = lngPasteRow + 1
Next
Columns("A:A").Delete
End Sub

Sortera bladflikar i bokstavsordning

Sub SorteraBladflikar()

Dim intAntalBlad As Integer
Dim i As Integer
Dim x As Integer
Application.ScreenUpdating = False
intAntalBlad = ActiveWorkbook.Worksheets.Count

For x = 1 To intAntalBlad
    For i = x To intAntalBlad
        If UCase(Worksheets(i).Name) < UCase(Worksheets(x).Name) Then
        Worksheets(i).Move before:=Worksheets(x)
        End If
    Next i
Next x
End Sub

Skapa en lista över samtliga kommentarer i ett kalkylblad

Sub ListaKommentarer()
Dim intAntalKommentarer As Integer
Dim Cell As Range
Dim x As String
Dim wksKommentarBlad As Worksheet
Dim intGammaltBlad As Integer
Dim Row As Integer
'*********************************************************************************************
intAntalKommentarer = 0
For Each Cell In ActiveSheet.UsedRange
On Error Resume Next
x = Cell.Comment.Text
If Err = 0 Then intAntalKommentarer = intAntalKommentarer + 1
Next Cell
If intAntalKommentarer = 0 Then
   MsgBox "Kalkylbladet innehåller inte några kommentarer.", vbInformation
   Exit Sub
End If

' Skapa en ny arbetsbok med ett blad
On Error GoTo 0
Set wksKommentarBlad = ActiveSheet
intGammaltBlad = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = intGammaltBlad
ActiveWorkbook.Windows(1).Caption = "Kommentarer för " & _
wksKommentarBlad.Name & " i " & wksKommentarBlad.Parent.Name

Row = 1
Cells(Row, 1) = "Cell"
Cells(Row, 2) = "Innehåll"
Cells(Row, 3) = "Kommentar "
Range(Cells(Row, 1), Cells(Row, 3)).Font.Bold = True
For Each Cell In wksKommentarBlad.UsedRange
   On Error Resume Next
   x = Cell.Comment.Text
   If Err = 0 Then
      Row = Row + 1
      Cells(Row, 1) = Cell.Address(False, False) 'Visa relativ cellreferens
      Cells(Row, 2) = " " & Cell.Formula
      Cells(Row, 3) = Cell.Comment.Text
   End If
Next Cell
Columns("B:C").AutoFit
Cells.EntireRow.AutoFit
End Sub

Funktion som visar månadsnamnet utifrån månadsnummer

Function Månadsnamn(Månadsnummer As Integer) As String
Select Case Månadsnummer
    Case Is = 1
        Månadsnamn = "Januari"
    Case Is = 2
        Månadsnamn = "Februari"
    Case Is = 3
        Månadsnamn = "Mars"
    Case Is = 4
        Månadsnamn = "April"
    Case Is = 5
        Månadsnamn = "Maj"
    Case Is = 6
        Månadsnamn = "Juni"
    Case Is = 7
        Månadsnamn = "Juli"
    Case Is = 8
        Månadsnamn = "Augusti"
    Case Is = 9
        Månadsnamn = "September"
    Case Is = 10
        Månadsnamn = "Oktober"
    Case Is = 11
        Månadsnamn = "November"
    Case Is = 12
        Månadsnamn = "December"
    Case Else
        Månadsnamn = "Felaktigt månadsnummer"
End Select
End Function

Skriv ut alla kalkylbladsformler i ett Worddokument

Denna procedur skapar ett nytt worddokument och skriver ut alla formler i ett markerat område i ett kalkylblad. 
OBS! För att kunna köra proceduren måste du lägga till Words objektbibliotek via menyn Verktyg-Referenser i Visual Basic Editorn.

Sub SkrivUtFormler()
    Dim strFormel As String, rngOmråde As Range
    Dim wordApp As Word.Application
    Dim bolMatris As Boolean
    On Error Resume Next
    Err.Number = 0
    
    Set wordApp = CreateObject("Word.Application")
    With wordApp
        .Visible = True
        .Documents.Add
        With .Selection
            .Font.Bold = True
            .Font.Name = "Courier New"
            .TypeText "Formler i " & ActiveSheet.Name & " i " & ActiveWorkbook.Name
            .TypeParagraph
            .TypeText "Cell: " + Selection.Cells(1, 1).Address(False, False, xlA1) _
            (Selection.Rows.Count, Selection.Columns.Count).Address(False, False, xlA1)
            .TypeParagraph
            .TypeParagraph
        End With
    End With
    For Each rngOmråde In Selection
        bolMatris = rngOmråde.HasArray
        strFormel = rngOmråde.Formula
        If bolMatris Then
            strFormel = "{" & strFormel & "}"
        End If
        If strFormel <> "" Then
            With wordApp.Selection
                .Font.Bold = True
                .TypeText rngOmråde.Address(False, False, xlA1) & ": "
                .Font.Bold = False
                .TypeText strFormel
                .TypeParagraph
                .TypeParagraph
            End With
        End If
    Next
    Set wordApp = Nothing
End Sub

Funktion som visar en formels konstanter i en enkel beräkning med ett räknesätt

Function ShowContent(Cell As Range) As String
    
    Dim Content As String, Range1 As String, Range2 As String, strOperator As String
    Dim Cellreference1 As Variant, CellReference2 As Variant
    Dim intLength As Integer, i As Integer, intOperator As Integer
    On Error GoTo ErrHandler
    Content = Cell.Formula
    intLength = Len(Content)
    For i = 1 To intLength
        If Mid(Content, i, 1) = "+" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
        If Mid(Content, i, 1) = "-" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
        If Mid(Content, i, 1) = "/" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
        If Mid(Content, i, 1) = "*" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
        If Mid(Content, i, 1) = "&" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
        If Mid(Content, i, 1) = "^" Then
            strOperator = Mid(Content, i, 1)
            Exit For
        End If
    Next
    intOperator = InStr(Content, strOperator)
    Range1 = Mid(Content, 2, intOperator - 2)
    Range2 = Mid(Content, intOperator + 1)
    Cellreference1 = Range(Range1).Value
    CellReference2 = Range(Range2).Value
    ShowContent = "=" & Cellreference1 & strOperator & CellReference2
    Exit Function
ErrHandler:
    ShowContent = "Formeln kan inte utvärderas"
End Function

Visa systeminformation i din dator

Sub VisaSysInfo()
    Dim strInfo As String
    Dim strVersion As String, strOs As String
    Dim strAnväntMinne As String, strLedigtMinne As String
    Dim strTotaltMinne As String
    

    strVersion = "Version: Excel " & Application.Version & vbNewLine
    strOs = "Operativsystem: " & _
    Application.OperatingSystem & vbNewLine
    strLedigtMinne = "Ledigt minne: " & _
    Format(Application.MemoryFree, "#,##0" & " bytes") & vbNewLine
    strAnväntMinne = "Använt minne:  " & _
    Format(Application.MemoryUsed, "#,##0" & " bytes") & vbNewLine
    strTotaltMinne = "Totalt minne: " & _
    Format(Application.MemoryTotal, "#,##0" & " bytes") & vbNewLine
    strInfo = strVersion & strOs & _
    strLedigtMinne & strAnväntMinne & strTotaltMinne
    MsgBox strInfo, vbInformation, "Systeminformation i " & _
    Application.UserName & "s dator"
End Sub

Visa skrivarinformation

Med den här proceduren kan du visa information om skrivarens namn, drivrutiner och vilken port den är ansluten till.

Private Declare Function GetProfileStringA Lib "kernel32" _
    (ByVal lpAppName As String, _
    ByVal lpKeyName As String, _
 ByVal lpDefault As String, _
    ByVal lpReturnedString As _
 String, ByVal nSize As Long) As Long

Sub SkrivarInfo()
    Dim strPort As String * 255
    Dim strResultat As String
    Dim strResultatLängd As Integer
    Dim intKomma1 As Integer
    Dim intKomma2 As Integer
    Dim Skrivare As String
    Dim Drivrutin As String
    Dim Port As String
    Dim strMeddelande As String
    
    Call GetProfileStringA _
       ("Windows", "Device", "", strPort, 254)
    
    strResultat = Application.Trim(strPort)
    strResultatLängd = Len(strResultat)

    intKomma1 = Application.Find(",", strResultat, 1)
    intKomma2 = Application.Find(",", strResultat, intKomma1 + 1)
    Skrivare = Left(strResultat, intKomma1 - 1)
    Drivrutin = Mid(strResultat, intKomma1 + 1, intKomma2 - intKomma1 - 1)
    Port = Right(strResultat, strResultatLängd - intKomma2)
    strMeddelande = "Din skrivare är en :" & vbTab & Skrivare & vbNewLine
    strMeddelande = strMeddelande & "Drivrutinen är :" & vbTab & Drivrutin & vbNewLine
    strMeddelande = strMeddelande & "Porten är :" & vbTab & Port
    MsgBox strMeddelande, vbInformation, "Skrivarinformation"
End Sub

Konvertera plusvärden till minus och vice versa

Denna procedur konverterar plusvärden till minusvärden i en markering

Sub ChangeValues()
Dim Cell As Range
For Each Cell In Selection
    Cell.Value = Cell.Value * -1
Next
Application.CutCopyMode = False
End Sub

Räkna överordnade och underordnade celler i en arbetsbok

Sub RäknaÖverordnadeUnderOrdnade()
     Dim ws As Worksheet
     Dim lngÖverordnade As Long
     Dim lngUnderordnade As Long
      

     On Error GoTo err
     For Each ws In Worksheets
         ws.Activate
         lngÖverordnade = 0
         lngUnderordnade = 0
         lngÖverordnade = Range("a1:iv65536").Dependents.Count
         lngUnderordnade = Range("a1:iv65536").Precedents.Count
         MsgBox ActiveSheet.Name & ":" & vbNewLine & _
                "Överordnade celler: " & lngÖverordnade & vbNewLine & _
                "Underordnade celler: " & lngUnderordnade, , Format(Date, "DDDD D MMMM YYYY")
     Next ws
     Exit Sub
err:
         Resume Next
End Sub

Radera de rader som uppfyller ett specifikt villkor

Markera först de celler i en kolumn som innehåller villkoret

Sub RaderaRader()
         Dim strRadera As String
         Dim rngMarkering As Range
         Dim intAntalRader As Integer
         Dim intFörstaRad As Integer
         Dim intSistaRad As Integer
         Dim intKolumn As Integer
         Dim intLoop As Integer
         Dim intRaderadeRader As Integer
         *******************************************************************

	strRadera = InputBox("Ange villkor för att radera raden?")
         Set rngMarkering = ActiveSheet.Range(ActiveWindow.Selection.Address)
         intAntalRader = rngMarkering.Rows.Count
         intFörstaRad = rngMarkering.Row
         intSistaRad = intFörstaRad + intAntalRader - 1
         intKolumn = rngMarkering.Column

         For intLoop = intSistaRad To intFörstaRad Step -1
             If Cells(intLoop, intKolumn) = strRadera Then
                 Rows(intLoop).Select
                 Selection.Delete Shift:=xlUp
                 intRaderadeRader = intRaderadeRader + 1
             End If
         Next intLoop
         MsgBox "Antal raderade rader: " & intRaderadeRader
     End Sub

Sub TestaADO()
    Dim conADO As New Connection
    Dim strConnection As String
    Dim strSQL As String
    Dim rstPoster As New Recordset
    Dim fldField As Field, i As Integer, x As Integer, y As Integer
    '********************************************************************************
    On Error GoTo Felhanteraren
    'Skapa en kopplingssträng. Kolla din sökväg
    strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
            & "Data Source=C:\Program\Microsoft Office\Office10\Samples\Northwind.mdb"
    'Öppna kopplingen till Databasen
    conADO.Open strConnection
    'Hämta alla poster i tabellen Kunder med ett SQL-uttryck
    strSQL = "SELECT * FROM Kunder"
    Set rstPoster.ActiveConnection = conADO
    'Öppna postuppsättningen
    rstPoster.Open strSQL
    i = 0: x = 1: y = 0: i = 1
    'Här loopar vi igenom postuppsättningen
    Do Until rstPoster.EOF
        i = i + 1
        x = 1
        'Nu loopar vi igenom alla fält och placerar
        'ut informationen i de olika kolumnerna
        For y = 0 To rstPoster.Fields.Count - 1
            Cells(i, x) = rstPoster.Fields(y)
            x = x + 1
        Next
        y = 0
        'Hämta nästa post
        rstPoster.MoveNext
    Loop
    'Återställ variabeln i till 1
    'Loopa genom alla fält och hämta fältnamnen
    i = 1
    For Each fldField In rstPoster.Fields
    'Placera ut fältnamnen på rad 1
        Cells(1, i) = fldField.Name
        i = i + 1
    Next
    Columns.AutoFit
    Rows(1).Font.Bold = True
    'Stäng kopplingen till databasen och töm minnet
    conADO.Close
    Set rstPoster = Nothing
    Set conADO = Nothing
    End
Felhanteraren:
    MsgBox Err.Description
End Sub	

Hämta samtliga tal ur en sträng

Anta att du har en kolumn där cellerna innehåller en blandning av text och tal där talet måste beräknas,
ex: ab345sd857. 
Nedanstående funktion lyfter ut ut siffrorna och konverterar det till ett tal. 

Function HämtaSiffrorUrSträng(strText As String) As Long
    Dim intLängd As Integer
    Dim strNy As String, strTal As String
    Dim i As Integer, x As Long
    'Loopa igenom samliga rader
    For x = 1 To Range("A65000").End(xlUp).Row
        'strNy = ""
        intLängd = Len(strText)
    'Loopa igenom strängen
        For i = 1 To intLängd
            strTal = Mid(strText, i, 1)
    'Om tecknet är numeriskt, lägg till det i strängen
            If IsNumeric(strTal) Then
                strNy = strNy & strTal
            End If
        Next
    'Konvertera till talformat med funktionen Val
       Siffra = Val(strNy)
    Next
End Function

Sub VisaLåsta()
    Dim rngOmråde As Range, rngCell As Range
    Set rngOmråde = Application.InputBox("Ange område" _ 
    , , Selection.Address, , , , , 8)
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each rngCell In rngOmråde
        If rngCell.Locked = True Then
            With rngCell
                .AddComment
                .Comment.Text Text:=Application.UserName & vbNewLine & "Låst"
            End With
        End If
    Next
End Sub										

Sub TaBortKommentar()
    Dim rngOmråde As Range, rngCell As Range
    Set rngOmråde = Application.InputBox("Ange område", , Selection.Address, , , , , 8)
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each rngCell In rngOmråde
        With rngCell
            .Comment.Delete
        End With
    Next
End Sub

Sub Rensa()
Dim intSistaKolumn As Integer, lngSistaRad As Long
intSistaKolumn = Range("IV1").End(xlToLeft).Column + 1
lngSistaRad = Range("A65536").End(xlUp).Row + 1
    Application.ScreenUpdating = False
    Columns(intSistaKolumn).Select
    Range(Selection, Selection.End(xlToRight)).Clea