Office: Excel hängt sich vor dem Speichern auf

Hallo zusammen!

und zwar habe ich folgendes Problem:

Ich habe eine Excel Mappe in der ich VBA Code ausführe. Wen ich diesen Code ausführe kann ich Excel nicht mehr richtig speichern bzw. auch nicht beenden ohne speichern weil Excel sich dann immer aufhängt.

Führe ich den Code nicht aus ist alles kein Problem ich kann speichern oder auch nicht es hängt sich nichts auf.

Anbei kurz zur erklärung welchen Code ich ausführe:

Code:

Option Explicit

Private Type SAFEARRAY1D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  cElements As Long
  lLbound As Long
End Type

Private Declare Sub BindArray Lib "kernel32" Alias "RtlMoveMemory" _
  (PArr() As Any, PSrc&, Optional ByVal cb& = 4)
Private Declare Sub ReleaseArray Lib "kernel32" Alias "RtlMoveMemory" _
  (PArr() As Any, Optional PSrc& = 0, Optional ByVal cb& = 4)

Private Declare Function CharLowerBuffA Lib "user32" _
  (lpsz As Any, ByVal cchLength&) As Long
Private Declare Function CharLowerBuffW Lib "user32" _
  (lpsz As Any, ByVal cchLength&) As Long
Private aLowChars%(&H8000 To &H7FFF)

Private Arr1() As Integer, S1Arr() As Integer, saS1Arr As SAFEARRAY1D
Private Arr2() As Integer, S2Arr() As Integer, saS2Arr As SAFEARRAY1D

Private Sub Class_Initialize()
  saS1Arr.cDims = 1: saS1Arr.cbElements = 2 '2 Bytes per Element
  BindArray S1Arr, VarPtr(saS1Arr)

  saS2Arr.cDims = 1: saS2Arr.cbElements = 2 '2 Bytes per Element
  BindArray S2Arr, VarPtr(saS2Arr)

  ReDim Arr1(8192): ReDim Arr2(8192) 'preinitialize our LowerBufArrays

  InitLowCharLUT
End Sub

Private Sub Class_Terminate()
  ReleaseArray S1Arr  'resets S1Arr into its original, "virginal" state
  ReleaseArray S2Arr  'resets S1Arr into its original, "virginal" state
End Sub


Public Function RatcliffSchmidtX(S1 As String, S2 As String) As Long
Dim i As Long, L1 As Long, L2 As Long, D As Single, LD As Long


  L1 = Len(S1): L2 = Len(S2)
  If L1 = 0 Or L2 = 0 Then Exit Function

  'pretest for exact similarity
  If L1 = L2 Then
    If S1 = S2 Then RatcliffSchmidtX = 100: Exit Function
  End If

  'make sure, we have enough space in our CompareBuffers
  If UBound(Arr1) < L1 + 1 Then ReDim Preserve Arr1(L1 + 1)
  If UBound(Arr2) <L2> 0.04 Then D = 0.04 'limit the Replacement-Reduction

  'reset the mapping
  saS1Arr.pvData = 0: saS1Arr.cElements = 0
  saS2Arr.pvData = 0: saS2Arr.cElements = 0

  If L1 = L2 Then 'test similarity again after preprocessing
    For i = 0 To L1 - 1
      If Arr1(i) <> Arr2(i) Then Exit For
    Next i
    If i = L1 Then RatcliffSchmidtX = (1 - D) * 100: Exit Function 'similar
  End If

  'now enter RatCliff with the preprocessed Buffers
  RatcliffSchmidtX = (2 * RatcliffRecurs(0, L1, 0, L2) / (L1 + L2) - D) * 100
  RatcliffSchmidtX = RatcliffSchmidtX - LD
  If RatcliffSchmidtX <0> 0 Or i = L - 2 Then
              Dst(j) = 97: Dst(j + 1) = 114: j = j + 2: i = i + 1
              ReplCount = ReplCount + 1
            Else ' 'er' somewhere in between - we do nothing
              Dst(j) = 101: j = j + 1
              If LChar = 101 Then ReplCount = ReplCount - 1
            End If
          Case Else: Dst(j) = 101: j = j + 1
            If LChar = 101 Then ReplCount = ReplCount - 1
        End Select
      Case 97 'a (ae,ai,ay are replaced with e)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 101, 105, 121: Dst(j) = 101: j = j + 1: i = i + 1 'ae,ai,ay
          Case 104: Dst(j) = 97: j = j + 1: i = i + 1 'ah to a
          Case Else: Dst(j) = 97: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 105, 106, 121, 252 'i,j,y,ü (ie,ih replaced with i)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 101, 104: Dst(j) = 105: j = j + 1: i = i + 1 'ie,ih to i
          Case Else: Dst(j) = 105: j = j + 1
            If LChar = 105 Then ReplCount = ReplCount - 1
        End Select
      Case 111 'o (oe,oi,oy are also replaced with e)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 101, 105, 121: Dst(j) = 101: j = j + 1: i = i + 1 'oe,oi,oy
          Case 104: Dst(j) = 111: j = j + 1: i = i + 1 'oh to o
          Case Else: Dst(j) = 111: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 117 'u (ue,ui,uy are replaced with i)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 101, 105, 121: Dst(j) = 105: j = j + 1: i = i + 1 'ue,ui,uy
          Case 104: Dst(j) = 117: j = j + 1: i = i + 1 'uh to u
          Case Else: Dst(j) = 117: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 99 'c
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 104, 107: Dst(j) = 107: j = j + 1: i = i + 1 'ch,ck to k
          Case Else: Dst(j) = 99: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 107 'k
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 115: Dst(j) = 120: j = j + 1: i = i + 1 'ks to x
          Case Else: Dst(j) = 107: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 115, 223 's and ß (replace the sequence sh with sk)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 104: Dst(j) = 115: Dst(j + 1) = 107: j = j + 2: i = i + 1
          Case Else: Dst(j) = 115: j = j + 1
            If LChar = 115 Then ReplCount = ReplCount - 1
        End Select
      Case 112 'p (replace ph with f)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 104: Dst(j) = 102: j = j + 1: i = i + 1 'ph to f
          Case Else: Dst(j) = 112: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case 100 'd (replace dt with t)
        Select Case aLowChars(Src(i + 1)) 'check next char
          Case 116: Dst(j) = 116: j = j + 1: i = i + 1 'dt to t
          Case Else: Dst(j) = 100: j = j + 1: ReplCount = ReplCount - 1
        End Select
      Case Else 'all other single chars get only copied
        Dst(j) = LChar: j = j + 1: ReplCount = ReplCount - 1
    End Select

Continue: Next i
  Dst(j) = 0 'set terminating NullChar
  L = j 'reflect the eventually reduced CharCount in L

  PreProcessing = ReplCount * 0.02 '2 percent reduction per replace
End Function

Private Function RatcliffRecurs(St1 As Long, End1 As Long, _
                                St2 As Long, End2 As Long) As Long
Dim i As Long, Max As Long
Dim a1 As Long, a2 As Long
Dim b1 As Long, b2 As Long
Dim S1 As Long, S2 As Long

  If (End1 <= St1 Or End2 <= St2) Then Exit Function
  If (End1 = St1 + 1 And End2 = St2 + 1) Then Exit Function

  b1 = End1: b2 = End2

  a1 = St1
  Do While a1 < b1

    a2 = St2
    Do While a2 < b2
      If Arr1(a1) = Arr2(a2) Then

        'determine length of common substring
        i = 1
        Do While Arr1(a1 + i) <0> Max Then
          Max = i: S1 = a1: S2 = a2
          b1 = End1 - Max: b2 = End2 - Max
        End If
      End If
      a2 = a2 + 1
    Loop

    a1 = a1 + 1
  Loop
  If Max = 0 Then Exit Function

  Max = Max + RatcliffRecurs(S1 + Max, End1, S2 + Max, End2) 'RHS
  Max = Max + RatcliffRecurs(St1, S1, St2, S2) 'LHS
  RatcliffRecurs = Max
End Function


Private Sub InitLowCharLUT()
Dim j&
  'inits a lookup-table for fast (unicode-aware) Lower-Lookups
  For j = -32768 To 32767: aLowChars(j) = j: Next j
  If CharLowerBuffW(aLowChars(-32768), &H10000) = 0 Then
    CharLowerBuffA aLowChars(65), (223 - 65) * 2
  End If

  ' patch the stooges
  ' S 138/352, s 154/353 | O 140/338, o 156/339 | Z 142/381, z 158/382 |
  ' Y 159/376, ÿ 255/255
  aLowChars(138) = 154: aLowChars(352) = 353
  aLowChars(140) = 156: aLowChars(338) = 339
  aLowChars(142) = 158: aLowChars(381) = 382
  aLowChars(159) = 255: aLowChars(376) = 255
End Sub

Und zwar rufe ich die Api Funktion

Code:

clsRatcliffSchmidVBA

Mit folgender VBA Funktion auf

Code:

Public Function RatcliffVBA(S1 As String, S2 As String) As Integer
    RatcliffVBA = CSRat.RatcliffSchmidtX(S1, S2)
End Function

Sobald ich diese Funktion auch nur einmal benutz habe hängt sich Excel auf aber erst wen ich speichern oder Beenden will. Also ich kann soweit ganz normal weiterarbeiten bis ich die Mappe speichern will.

Ich denke es hängt irgendwie mit folgenden Kernel32 deklarationen zusammen:

Code:

Private Declare Sub BindArray Lib "kernel32" Alias "RtlMoveMemory" _
  (PArr() As Any, PSrc&, Optional ByVal cb& = 4)
Private Declare Sub ReleaseArray Lib "kernel32" Alias "RtlMoveMemory" _
  (PArr() As Any, Optional PSrc& = 0, Optional ByVal cb& = 4)

Private Declare Function CharLowerBuffA Lib "user32" _
  (lpsz As Any, ByVal cchLength&) As Long
Private Declare Function CharLowerBuffW Lib "user32" _
  (lpsz As Any, ByVal cchLength&) As Long
Private aLowChars%(&H8000 To &H7FFF)

sobald ich diese nämlich weglasse hängt sich die Mappe nicht mehr auf. Nur leider geht dann halt auch meine Funktion nicht mehr richtig.

Hat vieleicht irgendjeman eine IDee muss ich die Klasse vieleicht irgendwie beenden oder killen bevor ich speichere?

Vielen dank schonmal

 

So Problem gefunden!!!

für alle die es interessiert:

nach ausführung der Funktion bzw. des Makros das die Funktion verwenden musste noch folgende Zeile ganze am Ende eingefügt werde:

Code:

Set CSRat = Nothing

somit hängt Excel sich nicht mehr auf!

Gruß