versuche es mal hiermit...
20.05.2009 11:28:03
Tino
Hallo,
nicht einfach zu verstehen bei VBA nein, teste mal ob es so funktioniert.
Habe dies nur an einem einfachen Beispiel getestet.
Option Explicit
Private Function CheckString(strString As String, strNummer As String) As String
Dim objRegExp As Object, objMatch As Object
Dim i As Integer
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = strNummer & "[a-z]{1,25}"
.IgnoreCase = True
Set objMatch = .Execute(strString)
End With
If objMatch.Count > 0 Then
CheckString = objMatch(0).Value
End If
Set objRegExp = Nothing
End Function
Sub TXT_Bearbeiten()
Dim sInhalt As String, sFilename As String
Dim F As Integer
Dim MyAr1, myAr2, myAr3
Dim A As Long, B As Long, Erste As Long
Dim i As Integer
Dim strNummer As String
'hier erste Zeile angeben wo eingefügt werden soll
'1 = ab A1; 2 = ab A2 usw.
Erste = 1
sFilename = Application.GetOpenFilename("Text File (*.txt),*.txt")
strNummer = Application.InputBox("Trennzeichen Nummer?", "Nummer angeben", "223432", , , , , 1)
If sFilename <> CStr(False) Then
'TXT einlesen
F = FreeFile
Open sFilename For Binary As #F
sInhalt = Space$(LOF(F))
Get #F, , sInhalt
Close #F
'Leerzeichen durch Semikolon ersetzen
sInhalt = Replace(sInhalt, " ", ";")
'hier die max Anzahl Semikolons angeben die vorkommen könnten
'hier bin ich mal von 10 ausgegangen
For i = 10 To 2 Step -1
sInhalt = Replace(sInhalt, String(i, ";"), ";")
Next i
MyAr1 = Split(sInhalt, vbCr)
With Application
.ScreenUpdating = False
.EnableEvents = False
ActiveSheet.UsedRange.Value = "" 'Tabelle für neue Daten leer machen
For A = Lbound(MyAr1) To Ubound(MyAr1)
sInhalt = CheckString(CStr(MyAr1(A)), strNummer)
sInhalt = Replace(MyAr1(A), sInhalt, "<|>" & sInhalt)
myAr2 = Split(sInhalt, "<|>")
For B = Lbound(myAr2) To Ubound(myAr2)
If .WorksheetFunction.Clean(myAr2(B)) <> "" Then
myAr3 = Split(.WorksheetFunction.Clean(myAr2(B)), ";")
If Ubound(myAr3) >= 0 Then
'Daten in Zellen schreiben
Cells(Erste, 1).Resize(, Ubound(myAr3) + 1) = myAr3
End If
Erste = Erste + 1 'nächste Zelle
End If
Next B
Next A
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Gruß Tino