Hi Marco,
ich habe alle drei - in meinen vorherigen Forumbeiträgen angeführten Funktionen/Prozeduren - geringfügig verändert/verbessert, hier in diesem Forumbeitrag unten nochmal angeführt.
Alle drei alten Funktionen/Prozeduren sind damit hinfällig und können durch die nachfolgend angeführten ersetzt bzw. in ein globales Modul eingefügt werden.
An der Funktionsweise bzw. wie diese angewendet werden müssen hat sich nichts geändert.
Option Compare Database
Option Explicit
Public Function fctLaengstesWort(ByRef varZeile As Variant) As Variant
Dim varWorte As Variant
Dim strLaengstesWort As String
Dim lngI As Long
If Len(varZeile) > 0 Then
varWorte = Split(Replace$(Replace$(varZeile, Chr$(13), " "), Chr$(10), vbNullString), " ")
For lngI = LBound(varWorte) To UBound(varWorte)
If Len(strLaengstesWort) 0 Then
fctLaengstesWort = strLaengstesWort
End If
End If
End Function
Public Sub subWortTabelleErstellen(Optional ByRef strQuellTabelle As String = „tblSatz“, _
Optional ByRef strQuellFeld As String = „Satz“, _
Optional ByRef strZielTabelle As String = „tblWort_aus_tblSatz“)
Dim db As DAO.Database
Dim rsQuell As DAO.Recordset
Dim rsZiel As DAO.Recordset
Dim varWorte As Variant
Dim lngI As Long
On Error GoTo Sub_FehlerBehandlung
DoCmd.Hourglass True
Set db = CurrentDb
If DCount("*", „[MSysObjects]“, „[Name] = '“ & strZielTabelle & „’“) 0 Then
db.Execute "DROP TABLE " & strZielTabelle
End If
db.Execute „CREATE TABLE " & strZielTabelle & " ( [Wort] TEXT(255) NOT NULL CONSTRAINT Wort_PK PRIMARY KEY , [WortAnzahl] LONG NOT NULL )“, dbFailOnError
Application.RefreshDatabaseWindow
db.Execute „CREATE INDEX WortAnzahl ON " & strZielTabelle & " ( [WortAnzahl] )“, dbFailOnError
Set rsQuell = db.OpenRecordset(strQuellTabelle, dbOpenSnapshot)
Set rsZiel = db.OpenRecordset(strZielTabelle, dbOpenDynaset)
Do While rsQuell.EOF = False
varWorte = Split(Replace$(Replace$(rsQuell(strQuellFeld) & vbNullString, Chr$(13), " "), Chr$(10), vbNullString), " ")
For lngI = LBound(varWorte) To UBound(varWorte)
If Len(varWorte(lngI)) > 0 Then
rsZiel.FindFirst „[Wort] = '“ & varWorte(lngI) & „’“
If rsZiel.NoMatch = True Then
rsZiel.AddNew
rsZiel!Wort = varWorte(lngI)
rsZiel!WortAnzahl = 1
Else
rsZiel.Edit
rsZiel!WortAnzahl = rsZiel!WortAnzahl + 1
End If
rsZiel.Update
End If
Next lngI
rsQuell.MoveNext
Loop
Sub_VerlassenRoutine:
rsQuell.Close
rsZiel.Close
Set rsQuell = Nothing
Set rsZiel = Nothing
Sub_Verlassen:
Set db = Nothing
DoCmd.Hourglass False
Exit Sub
Sub_FehlerBehandlung:
Select Case Err.Number
Case 3211 ’ … „Das Datenbankmodul konnte die Tabelle ‚|‘ nicht sperren, da sie bereits von einem anderen Benutzer oder Vorgang bearbeitet wird.“-Fehler
MsgBox Err.Description & " ( " & Err.Number & " )", vbOKOnly + vbCritical + vbMsgBoxHelpButton, „Import“, Err.HelpFile, Err.HelpContext
Resume Sub_Verlassen
Case Else ’ … Sonstiger Fehler
MsgBox Err.Description & " ( " & Err.Number & " )", vbOKOnly + vbCritical + vbMsgBoxHelpButton, „Import“, Err.HelpFile, Err.HelpContext
Resume Sub_VerlassenRoutine
End Select
End Sub
Public Sub subZeichenTabelleErstellen(Optional ByRef strQuellTabelle As String = „tblSatz“, _
Optional ByRef strQuellFeld As String = „Satz“, _
Optional ByRef strZielTabelle As String = „tblZeichen_aus_tblSatz“)
Dim db As DAO.Database
Dim rsQuell As DAO.Recordset
Dim rsZiel As DAO.Recordset
Dim strZeichen As String
Dim lngI As Long
On Error GoTo Sub_FehlerBehandlung
DoCmd.Hourglass True
Set db = CurrentDb
If DCount("*", „[MSysObjects]“, „[Name] = '“ & strZielTabelle & „’“) 0 Then
db.Execute "DROP TABLE " & strZielTabelle
End If
db.Execute „CREATE TABLE " & strZielTabelle & " ( [Zeichen] TEXT(1) NOT NULL CONSTRAINT Zeichen_PK PRIMARY KEY , [ZeichenAnzahl] LONG NOT NULL )“, dbFailOnError
Application.RefreshDatabaseWindow
db.Execute „CREATE INDEX ZeichenAnzahl ON " & strZielTabelle & " ( [ZeichenAnzahl] )“, dbFailOnError
Set rsQuell = db.OpenRecordset(strQuellTabelle, dbOpenSnapshot)
Set rsZiel = db.OpenRecordset(strZielTabelle, dbOpenDynaset)
Do While rsQuell.EOF = False
For lngI = 1 To Len(rsQuell(strQuellFeld) & vbNullString)
strZeichen = UCase$(Mid$(rsQuell(strQuellFeld) & vbNullString, lngI, 1))
If strZeichen " " And _
strZeichen Chr$(10) And _
strZeichen Chr$(13) Then
rsZiel.FindFirst „[Zeichen] = '“ & strZeichen & „’“
If rsZiel.NoMatch = True Then
rsZiel.AddNew
rsZiel!Zeichen = strZeichen
rsZiel!ZeichenAnzahl = 1
Else
rsZiel.Edit
rsZiel!ZeichenAnzahl = rsZiel!ZeichenAnzahl + 1
End If
rsZiel.Update
End If
Next lngI
rsQuell.MoveNext
Loop
Sub_VerlassenRoutine:
rsQuell.Close
rsZiel.Close
Set rsQuell = Nothing
Set rsZiel = Nothing
Sub_Verlassen:
Set db = Nothing
DoCmd.Hourglass False
Exit Sub
Sub_FehlerBehandlung:
Select Case Err.Number
Case 3211 ’ … „Das Datenbankmodul konnte die Tabelle ‚|‘ nicht sperren, da sie bereits von einem anderen Benutzer oder Vorgang bearbeitet wird.“-Fehler
MsgBox Err.Description & " ( " & Err.Number & " )", vbOKOnly + vbCritical + vbMsgBoxHelpButton, „Import“, Err.HelpFile, Err.HelpContext
Resume Sub_Verlassen
Case Else ’ … Sonstiger Fehler
MsgBox Err.Description & " ( " & Err.Number & " )", vbOKOnly + vbCritical + vbMsgBoxHelpButton, „Import“, Err.HelpFile, Err.HelpContext
Resume Sub_VerlassenRoutine
End Select
End Sub
mfg
Huber
