Einbau von Funktion(en)
28.02.2017 15:39:27
Funktion(en)
Hi,
das geht im Prinzip so:
Function regexsamp(strText As String) As Boolean
' Die Variablen waren nicht geDimt
Dim objRegEx As Object, objmatch As Object
Dim intIndex
Set objRegEx = CreateObject("vbscript.regexp")
With objRegEx
.Global = True
.IgnoreCase = True
.Pattern = "^.*\.(xls|xlsm|xlsx|xlsb|xlst)$"
Set objmatch = .Execute(strText)
End With
For intIndex = 0 To objmatch.Count - 1
Next
Set objRegEx = Nothing
Set objmatch = Nothing
If intIndex = 0 Then
regexsamp = False
Else
regexsamp = True
End If
End Function
Sub TestMitRegEx()
Dim zelle As String
zelle = "C:\DiesIstEinTest\ExcelDatei.xlsx"
If regexsamp(zelle) Then
MsgBox "gefunden"
Else
MsgBox "nicht gefunden"
End If
End Sub
Die RegEx werde ich nie begreifen, das ist mir zu viel Einarbeitungsaufwand.
Abgesehen davon kommt es auf die Menge von Daten an, die man verarbeitet. Jeder einzelne Aufruf von Funktionen benötigt Zeit, und das Erzeugen eines x-beliebigen Objekts (ob createobject für ein RegEx oder ein anderes Objekt) erst Recht, da letzteres im Prinzip von der Platte nachgeladen werden muß.
Deshalb eine weitere Variante:
Function XlFile(s As String) As Boolean
Dim s3$, s4&
Const Ext4 = "xmbt "
s3 = LCase(Right(s, 4))
If Mid(s3, 1, 1) = "." Then
XlFile = s3 = ".xls"
Else
XlFile = Left(s3, 3) = "xls" And InStr(Ext4, Right(s3, 1)) > 0
End If
End Function
Sub TestMitXlFile()
Dim zelle As String
zelle = "C:\DiesIstEinTest\ExcelDatei.xlsx"
If XlFile(zelle) Then
MsgBox "gefunden"
Else
MsgBox "nicht gefunden"
End If
End Sub
Was es für einen Unterschied macht, kann man damit nachvollziehen:
Sub TestVergleich()
Dim zelle As String
Dim i&, imax&
Dim erg&(1 To 2)
Dim t0 As Single, t1 As Single
imax = 5000
erg(1) = 0: erg(2) = 0
t0 = Timer
For i = 1 To imax
zelle = "C:\DiesIstEinTest\ExcelDatei" & i & ".xlsx"
If XlFile(zelle) Then erg(1) = erg(1) + 1 Else erg(2) = erg(2) + 1
Next
t0 = (Timer - t0) * 1000
MsgBox t0 & " ms. erg(1)=" & erg(1) & " erg(2)=" & erg(2)
erg(1) = 0: erg(2) = 0
t1 = Timer
For i = 1 To imax
zelle = "C:\DiesIstEinTest\ExcelDatei" & i & ".xlsx"
If regexsamp(zelle) Then erg(1) = erg(1) + 1 Else erg(2) = erg(2) + 1
Next
t1 = (Timer - t1) * 1000
MsgBox t1 & " ms. erg(1)=" & erg(1) & " erg(2)=" & erg(2)
MsgBox "Regex benötigt " & t1 / t0 & " mal so viel Zeit wie XlFile."
End Sub
Das ergibt auf meiner (lahmen) Maschine einen Faktor von rund knapp 400.
Bei "sehr vielen" Daten ist es vorteilhafter, eine Funktion *nicht* jedesmal *einzeln* aufzurufen, sondern ein Array mit allen Daten zu übergeben:
Function XlArray(s) As Variant
Dim s3$, i&
Const Ext4 = "xmbt " ' gültige Buchstaben nach "xls"
For i = LBound(s) To UBound(s)
s3 = LCase(Right(s(i, 1), 4))
If Mid(s3, 1, 1) = "." Then
s(i, 1) = s3 = ".xls"
Else
s(i, 1) = Left(s3, 3) = "xls" And InStr(Ext4, Right(s3, 1)) > 0
End If
Next
XlArray = s
End Function
Sub TestXLArray()
Dim z, e4 As String
Dim i&, imax&
Const Ext4 = "xmbt kenucy" ' gültige und nicht gültige Buchstaben
Dim lenExt4&
Dim t0 As Single, t1 As Single
imax = 5000
lenExt4 = Len(Ext4)
t0 = Timer
ReDim z(1 To imax, 1 To 1)
For i = 1 To imax
e4 = Mid(Ext4, (i Mod lenExt4) + 1, 1)
If e4 = " " Then e4 = ""
z(i, 1) = "C:\DiesIstEinTest\ExcelDatei.xls" & e4
Next
t0 = (Timer - t0) * 1000
MsgBox t0 & " ms. für die Erzeugung der Testwerte"
Range("A1").Resize(imax, 1) = z
t1 = Timer
z = XlArray(z)
t1 = (Timer - t1) * 1000
MsgBox t1 & " ms zum Berechnen der Werte"
Range("B1").Resize(imax, 1) = z
End Sub
Ich habe hier bewußt ein "zweidimensionales" Array gewählt, weil man ein solches erhält, wenn man einen Bereich aus einem Tabellenblatt nimmt.
Anstelle der Erzeugung von Testnamen könntest Du auch eine Zuweisung zu Deinen Dateinamen machen, etwa
Sub ArrayAusBereich()
Dim z
Dim t0 As Single
Dim Bereich As String
t0 = Timer
Bereich = "A2:A200"
z = Range(Bereich).Value
z = XlArray(z)
Range(Bereich).Offset(, 1) = z
t0 = (Timer - t0) * 1000
MsgBox t0 & " ms für die Berechung von " & Bereich
End Sub
Viel Spaß beim Testen,
Michael