VGnet.dk - VBA i øvrigt

Koden anvendes helt på eget ansvar!

Indhold:

•  
• Sorteringsrutiner
• Annuitet
• Decimalt tal til/fra binært tal
• PIN-kode-huskeren "KKode"
• Find dubletter eller unikke værdier
• Statistisk multifunktion
• Manipulér en talserie

Sorteringsrutiner

Sub BobleSortInteger(liste() As Integer)
' (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 

Sub BobleSortDouble(liste() As Double)
' (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 

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

Sub QuickSort(lft As Integer, rgt As Integer, liste As Variant)
' (C) Copyright Lars Vangsgaard
  Dim i As Integer, j As Integer, x As String, w As String
  i = lft
  j = rgt
  x = liste((lft + rgt) \ 2)
  Do
    Do While liste(i) < x
      i = i + 1
    Loop
    Do While liste(j) > x
      j = j - 1
    Loop
    If i <= j Then
      w = liste(i)
      liste(i) = liste(j)
      liste(j) = w
      i = i + 1
      j = j - 1
    End If
  Loop Until i > j
  If lft < j Then
    Call QuickSort(lft, j, liste)
  End If
  If i < rgt Then
    Call QuickSort(i, rgt, liste)
  End If
End Sub

Sub TestQuickSort()
' (C) Copyright Lars Vangsgaard
  Dim EnListe, i
  ReDim EnListe(1 To 10)
  EnListe(1) = "Her er"
  EnListe(2) = "en hel masse"
  EnListe(3) = "tekst, som"
  EnListe(4) = "skal sorteres"
  EnListe(5) = "af en smart ny"
  EnListe(6) = "funktion, som"
  EnListe(7) = "jeg har skrevet"
  EnListe(8) = "af efter"
  EnListe(9) = "en bog."
  EnListe(10) = "og dermed basta."
  Call QuickSort(1, 10, EnListe)
  For i = 1 To 10
    Cells(i, 1) = EnListe(i)
  Next 'i
End Sub

Annuitet

Function Annuitet(Rente As Double, Loebetid As Integer) As Double
' (C) Copyright Lars Vangsgaard
  Annuitet = Rente / (1 - (1 + Rente) ^ (-Loebetid))
End Function

Decimalt tal til/fra binært tal

Function BinaerEnc(ByVal x As Integer) As String
' (C) Copyright Lars Vangsgaard
' Omdanner et heltal til binært tal som streng
  Dim h, k, l, i
  If x < 0 Then
    BinaerEnc = ""
  ElseIf x = 0 Then
    BinaerEnc = "0"
  Else
    k = ""
    h = x
    l = 1 + Fix(Log(x + 0.001) / Log(2))
    For i = 1 To l
      If h >= 2 ^ (l - i) Then
        k = k & "1"
        h = h - 2 ^ (l - i)
      Else
        k = k & "0"
      End If
    Next i
    BinaerEnc = k
  End If
End Function 

Function BinaerDec(ByVal S As String) As Integer
' (C) Copyright Lars Vangsgaard
' Omdanner et binært tal som streng til heltal
  Dim h, k, l, c, i
  l = Len(S)
  k = ""
  For i = 1 To l
    c = Mid(S, i, 1)
    If c = "0" Or c = "1" Then
      k = k + c
    End If
  Next i
  l = Len(k)
  If l = 0 Then
    BinaerDec = 0
  Else
    h = 0
    For i = 1 To l
      c = Mid(k, i, 1)
      If c = "1" Then
        h = h + 2 ^ (l - i)
      End If
    Next i
    BinaerDec = h
  End If
End Function

PIN-kode-huskeren "KKode"

Function KKode(kode As Integer, basis As Integer, ind As Boolean)
' (C) Copyright Lars Vangsgaard
  Dim kstr As String, i As Integer, denne As Integer, res As String
  kstr = CStr(kode)
  If ind Then
    res = ""
    denne = basis
    For i = 1 To Len(kstr)
      denne = (denne + CInt(Mid(kstr, i, 1))) Mod 10
      res = res + CStr(denne)
    Next i
  Else
    res = CStr((10 + CInt(Mid(kstr, 1, 1)) - basis) Mod 10)
    If Len(kstr) > 1 Then
      For i = 2 To Len(kstr)
        res = res + CStr((10 + CInt(Mid(kstr, i, 1)) - CInt(Mid(kstr, i - 1, 1))) Mod 10)
      Next i
    End If
  End If
  KKode = res
End Function

Find dubletter eller unikke værdier

Function Dubletter(rng As Range) As Boolean
' (C) Copyright Lars Vangsgaard
  Dim dic, cl
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  For Each cl In rng
    If Not IsEmpty(cl) Then
      dic.Add UCase(CStr(cl.Value)), 0
      If Err <> 0 Then
        Dubletter = True
        On Error GoTo 0
        Exit Function
      End If
    End If
  Next
  On Error GoTo 0
  Set dic = Nothing
End Function

Function DubletterMedd(rng As Range) As Boolean
' (C) Copyright Lars Vangsgaard
  Dim dic, cl, msg
  msg = ""
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  For Each cl In rng
    If Not IsEmpty(cl) Then
      dic.Add UCase(CStr(cl.Value)), 0
      If Err <> 0 Then
        Dubletter = True
        msg = msg & vbCrLf & cl.Value
        Err.Clear
      End If
    End If
  Next
  On Error GoTo 0
  If Dubletter = True Then
    MsgBox "Dubletter:" & vbCrLf & vbCrLf & msg
  End If
  Set dic = Nothing
End Function

Function FindAlleKombinationer(KolonneBegynd As Integer, KolonneSlut As Integer, RækkeBegynd As Integer, Skillestreng As String)
' (C) Copyright Lars Vangsgaard
' Finder alle kombinationer af celleindhold indenfor et område i regnearket
' Returnerer et array af kombinationer inkl. skilletegn(/-strenge)
' Anvendelse: f.eks....
'Sub TestFindAlleKombinationer()
'  Dim i, a
'  a = FindAlleKombinationer(1, 3, 5, "#")
'  For i = LBound(a) To UBound(a)
'    Debug.Print a(i)
'  Next i
'End Sub
  Dim i As Integer, j As Integer, RækkeSlut As Integer, Kombination As String
  Dim dic As Object
  If KolonneBegynd > KolonneSlut Then Exit Sub
  RækkeSlut = Cells(RækkeBegynd, KolonneBegynd).CurrentRegion.Cells(Cells(RækkeBegynd, KolonneBegynd).CurrentRegion.Cells.Count).Row
  If RækkeBegynd > RækkeSlut Then Exit Sub
  Set dic = CreateObject("Scripting.Dictionary")
  For i = RækkeBegynd To RækkeSlut
    Kombination = Cells(i, KolonneBegynd)
    If KolonneSlut > KolonneBegynd Then
      For j = KolonneBegynd + 1 To KolonneSlut
        Kombination = Kombination & Skillestreng & Cells(i, j)
      Next j
    End If
    'Debug.Print Kombination
    On Error Resume Next
    dic.Add Kombination, Kombination
  Next i
  FindAlleKombinationer = dic.Keys
End Sub

Function RangeDimension(rg As Range) As Variant
' (C) Copyright Lars Vangsgaard
  If rg.Areas.Count > 1 Then
    RangeDimension = Array(3)
  Else
    If rg.Rows.Count = 1 Or rg.Columns.Count = 1 Then
      RangeDimension = Array(1, rg.Rows.Count, rg.Columns.Count)
    Else
      RangeDimension = Array(2, rg.Rows.Count, rg.Columns.Count)
    End If
  End If
End Function

Function FindUnikke(rg As Range, Optional drc As Byte) As Variant
' (C) Copyright Lars Vangsgaard
  Dim rgdim As Variant
  Dim dic As Object
  Dim cl As Range
  Dim data() As Variant
  Dim key As String
  Dim i, j As Long
  If IsMissing(drc) Then drc = 1
  If TypeName(rg) = "Range" Then rgdim = RangeDimension(rg) Else rgdim = Array(3)
  If drc < 1 Or drc > 2 Or rgdim(0) > 2 Then
    FindUnikke = Empty
    Exit Function
  End If
  Set dic = CreateObject("Scripting.Dictionary")
  If rgdim(0) = 1 Then
    On Error Resume Next
    For Each cl In rg
      dic.Add CStr(cl.Value), cl.Value
    Next cl
    On Error GoTo 0
    FindUnikke = Array(dic.Items)
  ElseIf rgdim(0) = 2 Then
    If drc = 1 Then
      On Error Resume Next
      For i = 1 To rgdim(1)
        key = ""
        ReDim data(1 To rgdim(2))
        For j = 1 To rgdim(2)
          key = key & "¤" & CStr(rg.Cells(i, j))
          data(j) = rg.Cells(i, j)
        Next j
        dic.Add key, data
      Next i
      On Error GoTo 0
      FindUnikke = dic.Items
    ElseIf drc = 2 Then
      On Error Resume Next
      For i = 1 To rgdim(2)
        key = ""
        ReDim data(1 To rgdim(1))
        For j = 1 To rgdim(1)
          key = "¤" & CStr(rg.Cells(j, i))
          data(j) = rg.Cells(j, i)
        Next j
        dic.Add key, data
      Next i
      On Error GoTo 0
      FindUnikke = dic.Items
    Else
      FindUnikke = Empty
    End If
  Else
    FindUnikke = Empty
  End If
  Set dic = Nothing
End Function

Sub TestFindUnikke()
' (C) Copyright Lars Vangsgaard
  Dim h, wb
  h = FindUnikke(Selection, 1)
  Set wb = Workbooks.Add
  wb.Activate
  SkrivArray h, wb.Sheets(1).Cells(1, 1)
  Set wb = Nothing
End Sub

Statistisk multifunktion

Function StatFunc(rng, op)
' Multifunktion indenfor statistik.
' Af John Walkenbach, http://www.j-walk.com/ss/excel/tips/tip43.htm, let ændret.
  Select Case UCase(op)
    Case "SUM"
      StatFunc = Application.Sum(rng)
    Case "AVG"
      StatFunc = Application.Average(rng)
    Case "MED"
      StatFunc = Application.Median(rng)
    Case "MOD"
      StatFunc = Application.Mode(rng)
    Case "CNT"
      StatFunc = Application.Count(rng)
    Case "MAX"
      StatFunc = Application.Max(rng)
    Case "MIN"
      StatFunc = Application.Min(rng)
    Case "VAR"
      StatFunc = Application.Var(rng)
    Case "STD"
      StatFunc = Application.StDev(rng)
    Case Else
      StatFunc = Evaluate("NA()")
  End Select
End Function

Manipulér en talserie

Function ØgAmplitude(ByVal yværdi, ByVal ytyngde, ByVal parameter)
' (C) Copyright Lars Vangsgaard
  ' Øger en "funktions" amplitude med faktor parameter i forhold til tallet ytyngde.
  ØgAmplitude = ytyngde + parameter * (yværdi - ytyngde)
End Function

Function DrejFunktion(ByVal yværdi, ByVal xværdi, ByVal xtyngde, ByVal xafstand, ByVal parameter)
' (C) Copyright Lars Vangsgaard
  ' "Drejer" en "funktion" mod uret om xtyngde med parameter pct. for xværdi=xtyngde+xafstand.
  ' f(xtyngde + xafstand) -> (1+parameter/100) * f(xtyngde + xafstand)
  ' f(xtyngde - xafstand) -> (1+parameter/100) * f(xtyngde - xafstand)
  ' Faktoren parameter skaleres lineært mellem xtyngde - xafstand og xtyngde + xafstand.
  DrejFunktion = yværdi * (1 + parameter * 0.01 * (xværdi - xtyngde) / xafstand)
End Function

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

█