AW: Wort finden und mit nachfolgendem Wort kopieren
21.02.2017 10:31:48
littletramp
Hallo Kirk
Hier trotzdem noch meine Lösung. Vielleicht gibt sie dir noch Ideen zur Verbesserungen deines Codes.
Der Text kann max. 2^31-1 = 2'147'483'647 Zeichen enthalten.
Die Grenze für das Array sind ebenfalls 2^31-1 Elemente je Dimension, d.h., man könnte jedes Zeichen eines Strings in ein Element einer Dimension des Arrays einlesen.
Ich habe mit einer Datei mit 65'000 Verweiseinträgen getestet (Dauer ca. 6 Sekunden).
Ich habe dir das Projekt hochgeladen https://www.herber.de/bbs/user/111623.xlsm
In folgendem Bereich kannst du Anpassungen vornehmen:
'----- Gewünschte Quelle aktivieren ----- (ev. anpassen!)
Const cQuelle = 1 ' 1: Zelle, 2: Textdatei, 3: Clipboard
Const cEingabezelle = "B1" ' Eingabezelle (ev. anpassen!)
strDatei = ThisWorkbook.Path & "\text.txt" '(ev. anpassen!)
' Ausgabeposition festlegen
Const c = 1 ' Ausgabespalte festlegen (ev. anpassen!)
r = 3 ' Startzeile für Ausgabe (ev. anpassen!)
Hier der Code:
Option Explicit
' Markus Schmid - Homepage: www.maschmid.ch
' Verweis auf "Microsoft Forms 2.0 Object Library"
' erforderlich -> Menü Extras | Verweise...
Public Sub ErzeugeVerweisliste()
Dim strDatei As String
Dim strWoerter() As String, strText As String
Dim i As Long, r As Long, lngAnz As Long
'----- Gewünschte Quelle aktivieren ----- (ev. anpassen!)
Const cQuelle = 1 ' 1: Zelle, 2: Textdatei, 3: Clipboard
Const cEingabezelle = "B1" ' Eingabezelle (ev. anpassen!)
strDatei = ThisWorkbook.Path & "\text.txt" '(ev. anpassen!)
' Ausgabeposition festlegen
Const c = 1 ' Ausgabespalte festlegen (ev. anpassen!)
r = 3 ' Startzeile für Ausgabe (ev. anpassen!)
On Error GoTo ErrHandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
' Alte Werte löschen
Range(Cells(r, c), Cells(Rows.Count, c + 1)).Clear
' Text aus Einlesequelle lesen
Select Case cQuelle
Case 1 ' Quelle: Zellinhalt
strText = Range(cEingabezelle).Text
Case 2 ' Quelle: Textdatei
strText = ReadFromTextfile(strDatei)
Case 3 ' Quelle: Zwischenspeicher
strText = ReadFromClipboard
Case Else
Err.Raise vbObjectError + 100, _
"ErzeugeVerweisliste", "Einlesequelle existiert nicht!!"
End Select
' Zeilenumbrüche und Tabulatoren ersetzen
strText = Replace(strText, vbLf, " ")
strText = Replace(strText, vbCrLf, " ")
strText = Replace(strText, vbCr, " ")
strText = Replace(strText, vbTab, " ")
' Leerzeichenserien entfernen (Bsp.: " " -> " ")
Do
lngAnz = Len(strText)
strText = Replace(strText, " ", " ")
Loop While lngAnz <> Len(strText)
strWoerter = Split(strText, " ")
lngAnz = UBound(strWoerter)
' Ergebnisliste ausgeben
For i = 1 To lngAnz
If IsNumeric(strWoerter(i)) Then
Cells(r, c).Value = strWoerter(i)
Cells(r, c + 1).Value = strWoerter(i - 1)
r = r + 1
End If
Next
ErrExit: ' ab hier weiter nach Fehlerbehandlung
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
Exit Sub
ErrHandler: ' Fehlerbehandlung
Select Case Err.Number
Case vbObjectError To vbObjectError + 65535
MsgBox "Ups, da ist etwas schief gelaufen!" & vbLf & vbLf _
& "Prozedur: " & Err.Source & vbLf _
& Err.Description
Case Else
MsgBox "Ups, da ist etwas schief gelaufen!" & vbLf & vbLf _
& "Fehler-Nr: " & Err.Number & vbLf _
& Err.Description
End Select
Resume ErrExit
End Sub
' Liest Text aus Textdatei und gibt diesen zurück
Private Function ReadFromTextfile(DateiPfadName As String) As String
Dim strZeile As String
Dim strText As String
Dim f As Long
If Len(Dir(DateiPfadName)) Then
f = FreeFile
Open DateiPfadName For Input As #f
Do Until EOF(1)
Line Input #f, strZeile
strText = strText & strZeile
Loop
Close #f
ReadFromTextfile = strText
Else
' Fehler erzeugen, wenn Textdatei nicht existiert
Err.Raise vbObjectError + 101, _
"ReadFromTextfile", _
"Die Datei existiert nicht!"
End If
End Function
' Liest Text aus Zwischenablage + gibt diesen zurück
' Verweis auf "Microsoft Forms 2.0 Object Library"
' erforderlich -> Menü Extras | Verweise...
Private Function ReadFromClipboard() As String
Dim objData As New DataObject
' Zwischenablage auslesen
objData.GetFromClipboard
' Fehlerbehandlung ausschalten, da Fehler
' falls Zwischenablage keinen Text enthält
On Error Resume Next
ReadFromClipboard = objData.GetText
Set objData = Nothing
' Fehler erzeugen, wenn kein Text in Zwischenablage
If Err.Number <> 0 Then
On Error GoTo 0 '
Err.Raise vbObjectError + 102, _
"ReadFromClipboard", _
"Die Zwischenablage enthält keinen Text!"
End If
End Function
Gruss Markus