VGnet.dk - Excel-manipulation med VBA

Koden anvendes helt på eget ansvar!

Indhold:

Den tid, et regneark senest er gemt

Function GemtTid()
' (C) Copyright Lars Vangsgaard
  Application.Volatile True
  GemtTid = Application.ActiveWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function

Opret eller fjern beskyttelse af alle ark

Sub Beskyt()
' (C) Copyright Lars Vangsgaard
' Beskytter alle faneblade (uden kodeord)
  Dim SH
  For Each SH In Sheets
    SH.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
  Next
End Sub
Sub UBeskyt()
' (C) Copyright Lars Vangsgaard
' Fjerner beskyttelse på alle faneblade (uden kodeord)
  Dim SH
  For Each SH In Sheets
    SH.Unprotect
  Next
End Sub

Vælg beregningsmåde i en pivottabel

Sub PivotFelter(Optional ByVal art As String)
' (C) Copyright Lars Vangsgaard
  Dim pf, pt, typ
  If IsMissing(art) Then art = "G"
  Select Case art
    'xlSum for sum, xlCount for antal, xlAverage for middelværdi...
    'xlMax, xlMin, xlProduct, xlCountNums, xlStDev, xlStDevP, xlVar, xlVarP
    Case "G": typ = xlAverage
    Case "S": typ = xlSum
    Case "A": typ = xlCount
    Case "H": typ = xlMax
    Case "L": typ = xlMin
    Case "P": typ = xlProduct
    Case "AN": typ = xlCountNums
    Case "SS": typ = xlStDev
    Case "SP": typ = xlStDevP
    Case "VS": typ = xlVar
    Case "VP": typ = xlVarP
    Case Else: typ = xlAverage
  End Select
  For Each pt In ActiveSheet.PivotTables
    For Each pf In pt.DataFields
      pf.Function = typ
    Next pf
  Next pt
End Sub

Funktionen kan behændigt styres med denne hjælperutine:

Sub VælgPivotindhold()
' (C) Copyright Lars Vangsgaard
  Dim medd, svar
  medd = "Vælg..."
  medd = medd & vbCrLf & "G for gennemsnit"
  medd = medd & vbCrLf & "S for sum"
  medd = medd & vbCrLf & "A for antal"
  medd = medd & vbCrLf & "H for høj (maksimum)"
  medd = medd & vbCrLf & "L for lav (minimum)"
  medd = medd & vbCrLf & "P for produkt"
  medd = medd & vbCrLf & "AN for antal numeriske"
  medd = medd & vbCrLf & "SS for standardafvigelse for stikprøve"
  medd = medd & vbCrLf & "SP for standardafvigelse for population"
  medd = medd & vbCrLf & "VS for standardafvigelse for stikprøve"
  medd = medd & vbCrLf & "VP for standardafvigelse for population"
  svar = UCase(InputBox(medd, "Tabelindhold", "G"))
  Call PivotFelter(svar)
  [A1].Activate
End Sub

Skift mellem automatisk og manuel beregning

Sub BytBeregningsmåde()
' (C) Copyright Lars Vangsgaard
'  Dim oldStatusBar
  With Application
'    oldStatusBar = .DisplayStatusBar
'    .DisplayStatusBar = True
    Select Case .Calculation
      Case xlCalculationAutomatic, xlCalculationSemiautomatic
        .Calculation = xlCalculationManual
        MsgBox "Manuel beregning valgt." & vbCrLf & "Brug F9 for at beregne."
      Case xlCalculationManual
        .Calculation = xlCalculationAutomatic
        MsgBox "Automatisk beregning valgt."
      Case Else
        .Calculation = xlCalculationAutomatic
        MsgBox "Automatisk beregning valgt."
    End Select
'    .StatusBar = False
'    .DisplayStatusBar = oldStatusBar
  End With
End Sub

Send arbejdsbogen med Outlook

Sub MailMedOutlook(ByVal Emne As String, ByVal Besked As String, _
                   ByVal VedhaeftDenneWorkbook As Boolean, ByVal til As String, _
                   Optional ByVal CCadr As String, Optional ByVal BCCadr As String)
' (C) Copyright Lars Vangsgaard
' Denne funktion kan kræve en reference i VBA-editoren (Tools, References...) til
' Microsoft Office ... Object Library eller Microsoft Outlook ... Object Library.
  Dim OutApp As Outlook.Application
  Dim OutMail As Outlook.MailItem
  Dim strto As String
  Dim strcc As String
  Dim strbcc As String
  Dim strsub As String
  Dim strbody As String
  Dim svar
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(olMailItem)
  strto = til
  If IsMissing(CCadr) Then strcc = "" Else strcc = CCadr
  If IsMissing(BCCadr) Then strbcc = "" Else strbcc = BCCadr
  strsub = Emne
  strbody = Besked
  With OutMail
    .To = strto
    .CC = strcc
    .BCC = strbcc
    .Subject = strsub
    .Body = strbody
    If VedhaeftDenneWorkbook Then
      svar = MsgBox("Skal vi gemme regnearket før du sender?", vbYesNo, "Gemme regneark?")
      If svar = vbYes Then ActiveWorkbook.Save
      .Attachments.Add ActiveWorkbook.FullName
    End If
    'I Excel 97 skal bruges ActiveWorkbook.Path & "\" & ActiveWorkbook.Name.
    '.Attachments.Add ("C:\test.txt")
    .Send ' eller .Display
  End With
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub

Omdøb et faneblad

... hvis man af én eller anden grund ikke ønsker at gøre det ved at dobbeltklikke på fanebladets navn.

Sub OmdøbFaneblad()
' (C) Copyright Lars Vangsgaard
  Dim navn
  navn = InputBox("Skriv fanebladets navn", "Omdøb faneblad", ActiveSheet.Name)
  If navn <> "" Then ActiveSheet.Name = navn
End Sub

Manipulér udseendet af en graf

Sub Grafskrifter()
' (C) Copyright Lars Vangsgaard
  Dim ch, wn
  wn = ActiveWorkbook.Name
  For Each ch In ActiveSheet.ChartObjects
    ch.Activate
    ActiveChart.ChartTitle.Select
    With Selection.Font
      .Size = 12
    End With
    ActiveChart.Axes(xlValue).Select
    With Selection.TickLabels.Font
      .Size = 10
    End With
    ActiveChart.Axes(xlValue).AxisTitle.Select
    With Selection.Font
      .Size = 10
    End With
    ActiveChart.Axes(xlCategory).Select
    With Selection.TickLabels.Font
      .Size = 10
    End With
    ActiveChart.Axes(xlCategory).AxisTitle.Select
    With Selection.Font
      .Size = 10
    End With
    ActiveChart.Legend.Select
    With Selection.Font
      .Size = 8
    End With
  Next ch
  ActiveWindow.Visible = False
  Windows(wn).Activate
  Range("A1").Select
End Sub
Sub Graftilpasning()
  Dim OvskStr, TextStr
  If TypeName(Selection) = "ChartArea" Then
    On Error Resume Next
    Do
      OvskStr = CDbl(InputBox("Overskriftens størrelse", "Overskriftstørrelse", 14))
    Loop Until Err = 0
    Do
      TextStr = CDbl(InputBox("Teksternes størrelse", "Tekststørrelse", 10))
    Loop Until Err = 0
    On Error GoTo 0
    ActiveChart.PlotArea.Select
    With Selection.Border
        .Weight = xlThin
        .LineStyle = xlAutomatic
    End With
    Selection.Interior.ColorIndex = xlNone
    ActiveChart.ChartTitle.Select
    Selection.AutoScaleFont = False
    With Selection.Font
      .Size = OvskStr
    End With
    ActiveChart.Axes(xlValue).Select
    Selection.TickLabels.AutoScaleFont = False
    With Selection.TickLabels.Font
      .Size = TextStr
    End With
    ActiveChart.Axes(xlValue).AxisTitle.Select
    Selection.AutoScaleFont = False
    With Selection.Font
      .Size = TextStr
    End With
    ActiveChart.Axes(xlCategory).Select
    Selection.TickLabels.AutoScaleFont = False
    With Selection.TickLabels.Font
      .Size = TextStr
    End With
    With Selection.TickLabels
        .Orientation = 45
    End With
    With Selection.Border
        .Weight = xlHairline
        .LineStyle = xlAutomatic
    End With
    With Selection
        .MajorTickMark = xlOutside
        .MinorTickMark = xlNone
        .TickLabelPosition = xlLow
    End With
    ActiveChart.Axes(xlCategory).AxisTitle.Select
    Selection.AutoScaleFont = False
    With Selection.Font
      .Size = TextStr
    End With
    ActiveChart.Legend.Select
    Selection.AutoScaleFont = False
    With Selection.Font
      .Size = TextStr
    End With
    ActiveChart.ChartArea.Select
  End If
End Sub

Slet knapper eller andre "shapes"

Nogle kontrolknapper hører til objekttypen "shape". Sådan sletter man dem:

Sub SletKnapper()
' (C) Copyright Lars Vangsgaard
  Dim sht, shp
  For Each sht In ThisWorkbook.Sheets
    For Each shp In sht.Shapes
      On Error Resume Next
      If shp.Type = 8 Or shp.Type = 12 Then
        MsgBox SH.Name & " " & SH.Type
        'shp.Select
        'Selection.Cut
        'CutCopyMode = False
      End If
      On Error GoTo 0
    Next shp
  Next sht
End Sub
Sub SletShapes()
' (C) Copyright Lars Vangsgaard
  Dim shp
  On Error Resume Next
  For Each shp In ActiveSheet.Shapes
    If (shp.Type <> 12) Then
    'If ((shp.Type <> 12) And (shp.Type <> 17)) Then
    '-2 = msoShapeTypeMixed
    ' 1 = msoAutoShape
    ' 2 = msoCallout
    ' 3 = msoChart
    ' 4 = msoComment
    ' 5 = msoFreeform
    ' 6 = msoGroup
    ' 7 = msoEmbeddedOLEObject
    ' 8 = msoFormControl
    ' 9 = msoLine
    '10 = msoLinkedOLEObject
    '11 = msoLinkedPicture
    '12 = msoOLEControlObject
    '13 = msoPicture
    '14 = msoPlaceholder
    '15 = msoTextEffect
    '16 = msoMedia
    '17 = tekstboks
      shp.Select
      Selection.Delete
    End If
  Next shp
  On Error GoTo 0
End Sub

Markér en regnearkstabel

Sub MarkerTabel(a As Range, r As Integer, k As Integer)
' (C) Copyright Lars Vangsgaard
' Markerer en tabel, idet den dropper r rækker og k kolonner.
  a.CurrentRegion.Offset(r, k).Resize(a.CurrentRegion.Rows.Count - r, _
    a.CurrentRegion.Columns.Count - k).Select
End Sub

Ret inddata til et bestemt tegn

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
' (C) Copyright Lars Vangsgaard
' Overvåger et område ved navn "Flueben" i et faneblad
' og ændrer inddata til "X".
' Det er vigtigt, at regnearket åbnes med makroer.
' Makroen skal ligge i fanebladets kodeobjekt.
  Dim VRange As Range, cell As Range
  Set VRange = Range("Flueben")
  For Each cell In Target
    If Union(cell, VRange).Address = VRange.Address Then
      If cell <> "" Then cell = "X"
    End If
  Next cell
End Sub

Kontrol for, om makroer er tilladt

' Kontrol for, om makroer er tilladt.
' Skal ligge i en mappes ThisWorkook-objekt.
' Desuden skal der være et faneblad "Advarsel" med en forklaring til brugeren
' om, at makroer skal være aktiveret for at bruge mappen ordentligt.

' Web-søgning med search.msn.com på 'Excel "macros disabled"'.
' Kilde: http://www.dotxls.com/excel-security/28/how-to-make-a-user-enable-excel-macros

' How to make a user enable Excel macros
' Users can set thier Excel Security to High, Medium or Low.
' Click on Tools-Macros-Security to set your Security level.
' High Security All Excel macros (except from trusted sources)are disabled
' Medium Security (recommended) User is prompted on each file-open to enable or disable Excel macros
' Low Security (not recommended) Excel Macros can run automatically without a prompt. You are not
' protected from potentially unsafe macros.
' Developer’s cannot control a user’s security settings and cannot force a user to run macros without
' seeing the pop-up security warning.
' If you wish users to enable macros you can make the Excel file unusable unless they are enabled. All
' sheets can be hidden unless the user enables macros.
' In the example below all sheets (except one) are hidden when the file is saved or closed.
' When the file is opened with Excel macros disabled the user will only see 1 sheet with a warning
' message.
' ie in cell b10: “Excel Macros must be enabled to use the workbook. Please close and reopen this file
' with Macros enabled”
' When the Excel file is opened with macros enabled the hidden worksheets will be automatically
' unhidden and the warning sheet will be hidden.
' When the Excel file is saved, all sheets except one are hidden.
' If the user saves without closing then the sheets remain hidden until the cursor is moved on the
' visible sheet.
' Note: Sheets are hidden on file-saving not file-closing.
' I used this logic as a user may save a workbook without closing. This would leave a copy of the
' saved workbook with unhidden sheets on the drive which others could open in read-only mode.
' Copy this code to the ThisWorkBook macro sheet:

Private Const dsWarningSheet As String = "Advarsel" 'Enter name of the Entry/Warning Page

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim ds
  For Each ds In ActiveWorkbook.Sheets
    If LCase(dsWarningSheet) = LCase(ds.Name) Then
      ds.Visible = True
    Else
      ds.Visible = xlVeryHidden
    End If
  Next ds
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal ds As Object, ByVal Target As Excel.Range)
  If LCase(ds.Name) = LCase(dsWarningSheet) Then
    For Each ds In ActiveWorkbook.Sheets
      ds.Visible = True
    Next ds
    ActiveSheet.Visible = xlVeryHidden
  End If
End Sub

Private Sub Workbook_Open()
  Dim ds
  Sheets(dsWarningSheet).Select
  For Each ds In ActiveWorkbook.Sheets
    ds.Visible = True
  Next ds
  ActiveSheet.Visible = xlVeryHidden
End Sub

Ret grafer eller serier i en graf

En "dummy", som viser, hvordan man får adgang til grafer eller grafserier.

Sub RetGraferEllerSerier()
' (C) Copyright Lars Vangsgaard
  ' Gør noget ved grafer eller serier i et regneark
  Dim ch, sr, svar, i
  For Each ch In ActiveSheet.ChartObjects
    ch.Activate
    svar = MsgBox("Redigér " & ActiveChart.ChartTitle.Caption & "?", vbOKCancel, "Redigér graf?")
    If svar = vbOK Then
      MsgBox ActiveChart.ChartTitle.Caption
      For Each sr In ActiveChart.SeriesCollection
        sr.Select
        MsgBox sr.Name
      Next sr
    End If
  Next ch
End Sub

Aktivér en bestemt celle

Sub GåTilCelle(cl As Range)
' (C) Copyright Lars Vangsgaard
  On Error Resume Next
  cl.Parent.Parent.Activate
  cl.Parent.Activate
  cl.Activate
  On Error GoTo 0
End Sub

Skriv et VBA-array til regneark

Sub SendArrayTilArk(uddata(), udcelle As Range)
' (C) Copyright Lars Vangsgaard
  Dim udrange As Range
  Set udrange = udcelle.Range(Cells(1, 1), Cells(UBound(uddata, 1) - LBound(uddata, 1) + 1, UBound(uddata, 2) - LBound(uddata, 2) + 1))
  udrange.Value = uddata
  Set udrange = Nothing
End Sub

Skriv en regnearkstabel til et VBA-array

Sub SkrivArrayTilDest(arr As Variant, Optional dest As Range)
' (C) Copyright Lars Vangsgaard
  Dim h As Variant
  Dim i As Integer, j As Integer
  Dim r As Range
  If IsMissing(dest) Then dest = ActiveCell
  ReDim h(1 To 1 + UBound(arr) - LBound(arr), 1 To 1 + UBound(arr(0)) - LBound(arr(0)))
  For i = LBound(arr) To UBound(arr)
    For j = LBound(arr(0)) To UBound(arr(0))
      h(1 + i - LBound(arr), 1 + j - LBound(arr(0))) = arr(i)(j)
    Next j
  Next i
  Set r = dest.Range(Cells(1, 1), Cells(1 + UBound(arr) - LBound(arr), 1 + UBound(arr(0)) - LBound(arr(0))))
  r.Value = h
  Set r = Nothing
End Sub

Sæt cellers farve efter deres værdi (heltal)

Sub FarvMarkering()
' (C) Copyright Lars Vangsgaard
  Dim cl As Range
  For Each cl In Selection
    With cl.Interior
      .ColorIndex = cl.Value + 1
      .Pattern = xlSolid
    End With
  Next cl
End Sub

Fjern hyperlinks

Sub FjernHyperlinks()
' (C) Copyright Lars Vangsgaard
  Dim cl
  On Error Resume Next
  For Each cl In Selection
    cl.Hyperlinks.Delete
  Next 'cl
  On Error GoTo 0
End Sub

Fjern cellers farve

Sub IngenBaggrundsfarve()
' (C) Copyright Lars Vangsgaard
  Selection.Interior.ColorIndex = xlNone
End Sub

Set skrå tekst i celler

Sub SkråTekst()
' (C) Copyright Lars Vangsgaard
  With Selection
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 15
    .AddIndent = False
    .ShrinkToFit = False
    .MergeCells = False
  End With
End Sub

Sæt ombrudt tekst i celler

Sub OmbrudtTekst()
' (C) Copyright Lars Vangsgaard
  With Selection
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .ShrinkToFit = False
    .MergeCells = False
  End With
End Sub

Markér UsedRange

Sub MarkerUsedRange()
' (C) Copyright Lars Vangsgaard
  On Error Resume Next
  ActiveWorkbook.ActiveSheet.UsedRange.Select
  On Error GoTo 0
End Sub

Vis arbejdsbogens navn

Sub VisMappensNavn()
' (C) Copyright Lars Vangsgaard
  InputBox "Mappens navn er", "Mappens navn", ActiveWorkbook.FullName
End Sub

Skift visning af en værktøjslinje

Sub SkiftVTL(navn As String)
' (C) Copyright Lars Vangsgaard
  Dim h As Boolean
  On Error Resume Next
  h = Application.CommandBars(navn).Visible
  Application.CommandBars(navn).Visible = Not h
  On Error Goto 0
End Sub

Lav en "død" kopi af et regneark

Bemærk, at der har været nogle problemer med at få denne rutine til at virke ordentligt!

Sub LavFiksKopi()
' (C) Copyright Lars Vangsgaard
' Lav en kopi af det aktive faneblad, hvor fanebladets billeder er "døde" kopier.
' Der sker ikke noget med originalen.
  Dim gn, nn, ch
  gn = ActiveWorkbook.Name
  ActiveSheet.Copy
  nn = ActiveWorkbook.Name
  For Each ch In ActiveSheet.ChartObjects
  ch.Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
    ActiveChart.Pictures.Paste.Select
    ActiveWindow.Visible = False
    Windows(nn).Activate
  Next ch
' Denne kodestump kan slette en evt. knap, man har knyttet koden til
'  ActiveSheet.Shapes("CommandButton1").Select
'  Selection.Delete
  Range("A1").Select
' Kopien efterstår nu som det aktive regneark.
' Denne kodestump kan gøre det gamle regneark til det aktive.
'  Windows(gn).Activate
End Sub

Fiksér indholdet af et antal regneark eller en hel arbejdsbog

Sub FikskopierRegneark(Optional AntalArk)
' (C) Copyright Lars Vangsgaard
  Dim wbg As Workbook, wbn As Workbook, i As Integer
  Set wbg = ThisWorkbook
  Set wbn = Workbooks.Add
  If IsMissing(AntalArk) Then AntalArk = wbg.Sheets.Count
  If AntalArk > wbn.Sheets.Count Then
    For i = wbn.Sheets.Count + 1 To AntalArk
      wbn.Sheets.Add
    Next i
  End If
  For i = 1 To AntalArk
    Windows(wbg.Name).Activate
    ActiveWorkbook.Sheets(i).Select
    Cells.Select
    Selection.Copy
    Windows(wbn.Name).Activate
    ActiveWorkbook.Sheets(i).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("A1").Select
    wbn.Sheets(i).Name = wbg.Sheets(i).Name
    Windows(wbg.Name).Activate
    ActiveSheet.Range("A1").Select
  Next i
  wbg.Sheets(1).Activate
  wbn.Sheets(1).Activate
  Set wbg = Nothing
  Set wbn = Nothing
End Sub
Sub TygRegneark(navn As String)
' (C) Copyright Lars Vangsgaard
  Dim wbg As Workbook, wbn As Workbook, i As Integer
  On Error Resume Next
  Set wbg = Workbooks.Open(navn)
  If Err <> 0 Then End
  On Error GoTo 0
  Set wbn = Workbooks.Add
  If wbg.Sheets.Count > wbn.Sheets.Count Then
    For i = wbn.Sheets.Count + 1 To wbg.Sheets.Count
      wbn.Sheets.Add
    Next i
  End If
  For i = 1 To wbg.Sheets.Count
    Windows(wbg.Name).Activate
    ActiveWorkbook.Sheets(i).Select
    Cells.Select
    Selection.Copy
    Windows(wbn.Name).Activate
    ActiveWorkbook.Sheets(i).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("A1").Select
    wbn.Sheets(i).Name = wbg.Sheets(i).Name
  Next i
  Application.DisplayAlerts = False
  wbg.Close
  Application.DisplayAlerts = True
  Set wbg = Nothing
  On Error Resume Next
  wbn.SaveAs navn
  If Err = 0 Then wbn.Close
  On Error GoTo 0
  Set wbn = Nothing
End Sub

Sortér arbejdsbogens ark efter navn

Sub SorterArk()
' (C) Copyright Lars Vangsgaard
' Denne rutine sorterer arkene i en mappe alfabetisk
  Dim ArkNavn() As String
  Dim ArkAntal As Integer, i As Integer
  Dim GammeltArk As Object
  On Error Resume Next
' Optælling og fejlkontrol
  ArkAntal = ActiveWorkbook.Sheets.Count
  If Err <> 0 Then Exit Sub
  If ActiveWorkbook.ProtectStructure Then
    MsgBox ActiveWorkbook.Name & " er beskyttet", vbCritical, "Kan ikke sortere arkene"
  End If
' Navnene lægges ind i en liste
  ReDim ArkNavn(1 To ArkAntal)
  For i = 1 To ArkAntal
    ArkNavn(i) = ActiveWorkbook.Sheets(i).Name
  Next i
' Sorter navnelisten
  Call BobleSortString(ArkNavn)
' Slå skærmopdatering fra
  Application.ScreenUpdating = False
' Gem hvilket ark der er aktivt
  Set GammeltArk = ActiveWorkbook.ActiveSheet
' Flyt arkene rundt
  For i = 1 To ArkAntal
    ActiveWorkbook.Sheets(ArkNavn(i)).Move ActiveWorkbook.Sheets(i)
  Next i
' Hent hvilket ark der var aktivt
  GammeltArk.Activate
' Slå skærmopdatering til
  Set GammeltArk = Nothing
  Application.ScreenUpdating = True
End Sub

Funktionen kræver adgang til en hjælperutine, der kan sortere:

Sub BobleSortString(liste() As String)
' (C) Copyright Lars Vangsgaard
' Denne rutine sorterer en vilkårlig liste
 Dim Forste As Integer, Sidste As Integer
  Dim i As Integer, j As Integer
  Dim Temp
' Styr på start- og slutindeks
  Forste = LBound(liste)
  Sidste = UBound(liste)
' Gennemløber listen en masse gange
  For i = Forste To Sidste - 1
    For j = i + 1 To Sidste
    ' Hvis det største står først, så byt om
      If liste(i) > liste(j) Then
        Temp = liste(j)
        liste(j) = liste(i)
        liste(i) = Temp
      End If
    Next j
  Next i
End Sub

For at der sorteres rigtigt skal følgende direktiv placeres øverst i modulet:

Option Compare Text

Udtræk en vilkårlig celle fra et område

Function UdtraekCelle(Omraade As Variant, Optional Genregn As Boolean)
' (C) Copyright Lars Vangsgaard
' Udtrækker en vilkårlig celle i et område
' Standardmåde statisk
  If IsMissing(Genregn) Then Genregn = False
  Application.Volatile Genregn
' Udtrækningen
  UdtraekCelle = Omraade(Int(Omraade.Count * Rnd) + 1)
End Function

Vend menuernes tekster om, så de bliver volapyk

En rutine, de kan bruges til at lave sjov med andre med. Alt-kombinationerne virker som de skal.

Sub ReverseMenuText()
' Made by John Valkenbach
  Dim m1, m2, m3
  On Error Resume Next
  For Each m1 In Application.CommandBars(1).Controls
    m1.Caption = Reverse(m1.Caption)
    For Each m2 In m1.Controls
      m2.Caption = Reverse(m2.Caption)
      For Each m3 In m2.Controls
        m3.Caption = Reverse(m3.Caption)
      Next m3
    Next m2
  Next m1
End Sub

Funktionen kalder følgende hjælpefunktion:

Function Reverse(MenuText As String) As String
' Made by John Valkenbach
' Returns menu item, backwards with original hot key
  Dim Temp As String, Temp2 As String
  Dim ItemLen As Integer, i As Integer
  Dim HotKey As String * 1
  Dim Found As Boolean
  ItemLen = Len(MenuText)
  Temp = ""
  For i = ItemLen To 1 Step -1
    If Mid(MenuText, i, 1) = "&" Then _
      HotKey = Mid(MenuText, i + 1, 1) _
    Else Temp = Temp & Mid(MenuText, i, 1)
  Next i
' Convert reversed string to Proper case
  Temp = Application.Proper(Temp)
' Insert & for hot key
  Found = False
  Temp2 = ""
  For i = 1 To ItemLen - 1
    If UCase(Mid(Temp, i, 1)) = UCase(HotKey) And Not Found Then
      Temp2 = Temp2 & "&"
      Found = True
    End If
    Temp2 = Temp2 & Mid(Temp, i, 1)
  Next i
' Transfer ellipses to end of string
  If Left(Temp2, 3) = "..." Then Temp2 = Right(Temp2, ItemLen - 3) & "..."
  Reverse = Temp2
End Function

 

Siden er oprettet 25-12-2006 og sidst opdateret 14-01-2007 22:53.

█