Her er nogle vba-koder som du måske kan bruge fra tid til anden. De er ikke tilgængelige som demofiler, men du er velkommen til at kopiere og bruge dem i dine filer mv. Du skal blot huske at ændre områder eller cellereferencer iht dine behov.

De er - indtil videre - inddelt i følgende grupper:

ARK

Celle

Kolonner

System

Søg

ARK

Sub Indsætmdrark()
Dim X As Integer
Worksheets.Add Count:=12
For X = 1 To 12
Worksheets(X).Name = Format(DateSerial(1997, X, 1), "mmmm")
Next X
End Sub

Sub OphævArkBeskyttelse()
Dim Wb As Workbook, Sh As Worksheet
For Each Wb In Workbooks
For Each Sh In Wb.Worksheets
Sh.Unprotect
Next Sh
Next Wb
End Sub

Sub Rullebegrænsning()
If ActiveSheet.ScrollArea = "" Then
Cells.Interior.ColorIndex = 17
Selection.Interior.ColorIndex = xlColorIndexNone
ActiveSheet.ScrollArea = Selection.Address
Else
ActiveSheet.ScrollArea = ""
Cells.Interior.ColorIndex = xlColorIndexNone
End If
End Sub

Sub Arkmeddatoerimdr()
Dim i As Integer
For i = 1 To 30
Worksheets(i).Name = Format(DateSerial _
(2001, 4, i), "dd.mm.yy")
Next i
End Sub

Sub DeleteSheet(strSheetName As String)
' deletes a sheet named strSheetName in the active workbook
Application.DisplayAlerts = False
Sheets(strSheetName).Delete
Application.DisplayAlerts = True
End Sub

Celle

Sub AfkortCelleKarakterer()
Dim C As Range
On Error Resume Next
For Each C In Selection
C = Left(C, 10)
Next C
End Sub

Sub Hvorerdenaktivecelle()
Dim Område As Object
Set Område = Application.Intersect(Range("i1:l10"), Range(ActiveCell.Address))
If Område Is Nothing Then MsgBox "Udenfor området" Else MsgBox "I området"
End Sub

Sub Nulstiltekstceller()
Dim C As Range
For Each C In Selection
If Not IsNumeric(C.Value) Then
C.Value = 0
End If
Next C
End Sub

Sub Kommentarfeltstørrelse()
Dim nykom As Comment
Set nykom = ActiveCell.AddComment
With nykom
.Text Text:=Application.UserName & ":" _
& Chr(10) & ""
With .Shape
.Height = 100
.Width = 100
End With
End With
End Sub

Sub Kommentaroverskriveshvisja()
Dim C As Range
For Each C In Selection
If Not C.Comment Is Nothing Then
C.NoteText "Opr kommentar er overskrevet af dette !"
End If
Next C
End Sub

Sub Viscelleværdi()
MsgBox Range("A10").Text
End Sub

Kopier celler, med flg kode:
Selection.Copy

Indsæt kopierede celler, med flg kode:
ActiveSheet.Paste

Kolonner

Sub SkjulFlereKol()
Dim Område As Range
Application.Goto Reference:=Range("d:f,h:i,k:n")
For Each Område In Selection.Areas
Område.EntireColumn.Hidden = True
Next Område
End Sub

Sub VisIgenFlereKol()
Dim Område As Range
Application.Goto Reference:=Range("d:f,h:i,k:n")
For Each Område In Selection.Areas
Område.EntireColumn.Hidden = False
Next Område
End Sub

System

Sub WindowsSystem()
If InStr(1, Application.OperatingSystem, "32") Then
MsgBox "32-Bit-System"
Else
MsgBox "16-Bit-System"
End If
End Sub

Sub Sprognummer()
MsgBox Application.International(1)
End Sub

Undgå diverse alerts med flg kode:
Application.DisplayAlerts = False

Når du vil se dem igen, brug da flg. kode:
Application.DisplayAlerts = True

Undgå alerts (fil gem) med flg kode:
ActiveWorkbook.Close False ' lukker den aktive fil UDEN at gemme ændringer

Når du vil se dem igen (fil gem), brug da flg. kode:
ActiveWorkbook.Close True ' lukker den aktive fil og gemmer alle ændringer

Når du vil aktivere en anden åben fil, brug da flg. kode:
Windows("filnavnet.xls").Activate

Når du vil indsætte en tekst i Statusbar'n, brug da flg. kode:
Application.StatusBar = "Alan Excel"

Søg

Sub SøgAccessExport()
Dim a As Range
Dim SøgMål
SøgMål = InputBox("Indtast det eftersøgte:")
If SøgMål = "" Then Exit Sub
For Each a In Selection
If a >= SøgMål - 1 And a <= SøgMål + 1 Then
a.Select
Exit Sub
End If
Next a
MsgBox "Det eftersøgte blev ikke fundet !"
End Sub