ActiveX DLL clsUDF

Od jakiegoś czasu chciałem stworzyć własny dodatek z najróżniejszymi rzeczami które są mi potrzebne do pracy, jednak

dodatek inny niż standardowe xla. Czemu? Chciałbym żeby kod funkcji i procedur był możliwie dobrze zabezpieczony choćby

dodatek można pobrać:

przed niechcianym kopiowaniem itp... Uznałem że najlepiej będzie stworzyć dodatek Automatyzacji, a że teoretycznie zadania

tkCOMAddIn.dll

realizowane za pomocą funkcji/procedur wykonywanych ze skompilowanej biblioteki powinny się wykonywać szybciej utwierdza

mnie w przekonaniu że to właściwa droga.

Docelowo chciałbym ten dodatek rozbudowywać jednak dziś pokażę jedynie funkcje użytkownika, które w nim zamieszczę.

Plan tego artykułu:

- Tworzenie ActiveX DLL w VB6

- Rejestrowanie dodatku automatyzacji

- Wstawienie dodatku do Excela

- Funkcja DefPozaTbl

- Funkcja DanePodWarunkiem.

- Funkcja VBALike

- Funkcje SortowanieBabelkoweV i SortowanieBabelkoweH

- Funkcje tblUnionZakresowV i tblUnionZakresowH

- Funkcje dot. Unikatów

- Porównanie czasów wykonania VBA i DLL.

Krótko na temat tworzenia ActiveX DLL.

Aby utworzyć dodatek automatyzacji (dll) korzystam z Microsoft Visual Basic 6.0 (VB6)

- Po włączeniu programu należy wybrać: Menu File / New Project -> ActiveX DLL

- W oknie Project Klikamy na Project1 i w oknie Properties nadajemy nazwę (Name) dla naszej biblioteki (moja tkCOMAddIn)

- to samo z nazwą modułu Class. (clsConnection)

- Następnie Menu Project / References. Dodajemy referencję do Microsoft Add-In Designer

- do modułu clsConnection kopiujemy taki kod:

Option Explicit

Implements IDTExtensibility2

Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, _

ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, _

ByVal AddInInst As Object, _

custom() As Variant)

Set modPublic.xlApp = Application

End Sub

Private Sub IDTExtensibility2_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, _

custom() As Variant)

Set modPublic.xlApp = Nothing

End Sub

Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant)

'Komentarz, aby VB nie usunął metody

End Sub

Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant)

'Komentarz, aby VB nie usunął metody

End Sub

Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant)

'Komentarz, aby VB nie usunął metody

End Sub

Tworzę obiekt Application jako publiczny obiekt zadeklarowany w module Standardowym modPublic a w nim.

Public xlApp As Object 'Excel.Application

Dodaję kolejny moduł class i nadaję mu nazwę clsUDF a w nim funkcje które chciałbym móc wykorzystywać w Excelu z tego

dodatku.

Następnie tworzymy bibliotekę dll i zapisujemy projekt.

- Menu File / Make tkCOMAddIn.dll

- Menu File / Save Project As..

Zapis do pliku dll od razu podejmie próbę zarejestrowania taj biblioteki w systemie. Jeżeli jednak chcemy żeby działała na innej

Rejestrowanie formantu ActiveX (.ocx) ręcznie

maszynie trzeba ją tam zarejestrować. Robi się to poprzez program Microsoft Register Server (Regsvr32.exe) --->

Mamy więc zarejestrowany dodatek automatyzacji (dll). Żeby korzystać z jego zawartości trzeba:

- korzystanie z publicznych funkcji zdefiniowanych w dodatku z poziomu Arkusza (jako funkcje arkuszowe)

Excel 2003: Zakładka: Narzędzia / Dodatku / Przycisk: Automatyzacja / W oknie dialogowym należy odszukać i wybrać:

tkCOMAddIn.clsConnection

tkCOMAddIn.clsUDF

Excel 2007/2010: Włączanie lub wyłączanie dodatków w programach pakietu Office

- z poziomu VBA

- poprzez "wczesne wiązanie": VBE / Tools / References / klik przy tkCOMAddIn

w procedurze / funkcji:

Dim objCls As tkCOMAddIn.clsUDF

Set objCls = new tkCOMAddIn.clsUDF

With objCls

tbl = .DanePodWarunkiem(tbl, .VBALike(tblWar, "A*"))

- poprzez "późne wiązanie"

Dim objCls As Object 'tkCOMAddIn.clsUDF

Set objCls = CreateObject("tkCOMAddIn.clsUDF")

With objCls

tblWyn2 = .DanePodWarunkiem(tbl, .VBALike(tblWar, "A*"))

Teraz co do zawartości clsUDF

Funkcja DefPozaTbl

Public Function DefPozaTbl(tbl As Variant, _

Optional vArg As Variant = vbNullString)

Dim w As Long, k As Integer

Dim nowaTbl() As Variant

Dim minW As Long, maxW As Long

Dim minK As Integer, maxK As Integer

Dim i As Long, j As Integer

With xlApp.Caller

w = .Rows.Count

k = .Columns.Count

End With

minW = LBound(tbl, 1): maxW = UBound(tbl, 1)

minK = LBound(tbl, 2): maxK = UBound(tbl, 2)

If maxW <= w Or maxK <= k Then

ReDim Preserve nowaTbl(minW To w, minK To k)

For i = minW To w

For j = minK To k

If i > maxW Or j > maxK Then

nowaTbl(i, j) = vArg

Else

nowaTbl(i, j) = tbl(i, j)

End If

DefPozaTbl = nowaTbl

Else

DefPozaTbl = tbl

End If

End Function

Jest to przeróbka procedury DefiniowanieZawartosciZakresuPozaTablica. Procedura tą zagnieżdżałem z kodach funkcji jednak

Definiowanie zawartosci zakresu poza tablicą

często przydaje się również przy innych formułach tablicowych gdzie zwracana tablica jest dynamiczna a poza nią formuła zwraca

błąd dopasowania wielkości zwracanej tablicy w porównaniu do miejsca na nią przeznaczoną.

Np.:

Przeznaczmy zakres 5x5 (A1:E5) na taką tablicę: ={1;2;3;4\11;12;13;14} otrzymamy

#N/D!

Zapiszmy jednak: =DefPozaTbl({1;2;3;4\11;12;13;14};"brak")

brak

Drugi argument jest opcjonalny. Pominięty zwraca poza tablicą pusty ciąg.

Funkcja Transponuj2. Nieodzownie konieczna przy tworzeniu dynamicznych tablic. Wykorzystywana zarówno jako "pod funkcja"

Funkcja Transponuj2

funkcji użytkownika które zwracają nieokreśloną od początku tablicę, jak i jako samodzielną funkcja.

Funkcja DanePodWarunkiem.

Public Function DanePodWarunkiem(tblDane As Variant, vWarunki As Variant) As Variant

Dim tbl As Variant, i As Long, j As Integer

Dim tblWyniki() As Variant, w As Long, k As Integer

tbl = tblDane: k = UBound(tbl, 2)

For i = 1 To UBound(tbl, 1)

If vWarunki(i, 1) Then

w = w + 1

ReDim Preserve tblWyniki(1 To k, 1 To w)

For j = 1 To k

tblWyniki(j, w) = tbl(i, j)

End If

If w > 0 Then

DanePodWarunkiem = Transponuj2(tblWyniki)

End If

End Function

Funkcja ta to taki mój filtr działający na dowolnych, czasem nawet dość skomplikowanych warunkach. Przykład podam wraz z

Funkcja DanePodWarunkiem

następną funkcją VBALike. Zawsze mi brakowało tego w Excelu. Może by to i jakoś obszedł, ale tak jest po prostu łatwiej :-)

Public Function VBALike(vDane As Variant, strLike As String) As Variant

Dim tbl As Variant, tblWyniki() As Boolean

Dim i As Long

tbl = vDane

ReDim tblWyniki(1 To UBound(tbl), 1 To 1)

For i = 1 To UBound(tbl)

tblWyniki(i, 1) = tbl(i, 1) Like strLike

VBALike = tblWyniki

End Function

Mamy taki przykład danych:

Test

Test2

Wart

kod

Test1

323,35

500-09-405-00

Test2

274,9

500-05-404-09

Test3

332,76

500-09-401-15

Test4

318,31

500-04-406-19

Test5

252,25

500-04-402-11

Test6

51,89

500-04-401-12

Test7

119,48

500-08-405-17

Test8

226,33

500-09-406-20

Test9

240,42

500-04-403-01

Test10

375,67

500-08-406-06

Test11

72,15

500-04-403-11

Test12

257,1

500-02-401-06

Test1

301,21

500-00-403-12

Test2

102,32

500-06-405-18

Test3

398,88

500-04-406-16

Test4

218,78

500-07-403-18

Test5

294,01

500-09-401-07

Test6

304,39

500-10-403-03

Test7

227,73

500-03-406-17

Test8

266,34

500-01-402-07

Chciałbym z tych danych wyfiltrować do nowego zakresu te rekordy które w kol.kod mają "*401*"

dane takie zwróci formuła =DefPozaTbl(DanePodWarunkiem(A2:E21;VBALike(E2:E21;"*401*")))

Test3

332,76

500-09-401-15

Test6

51,89

500-04-401-12

Test12

257,1

500-02-401-06

Test5

294,01

500-09-401-07

Puste komórki poniże danych oznaczają że formuła została wprowadzona do większego zakresu niż rozmiary tablicy z wynikami.

Normalnie w takich sytuacjach do tych komórek zostałby zwrócony błąd. Tu zawartość tej części tablicy zostaje wypełniona

zgodnie z drugim arg. f. DefPozaTbl.

Jednak chcielibyśmy żeby zwrócone dane były posortowane malejąco po czwartej kolumnie (wart)

Potrzebujemy zatem funkcji SortowanieBabelkoweV.

Funkcja SortowanieBabelkowe2D

Public Function SortowanieBabelkoweV(rngDane As Variant, _

CzyRosnaco As Boolean, _

ParamArray nrKolumn() As Variant) As Variant

Dim tabl As Variant

Dim nr As Variant

Dim xMax As Long, yMax As Integer, jTbl As Integer

Dim i As Long, j As Long, a As Long

Dim Temp

tabl = rngDane

xMax = UBound(tabl, 1): yMax = UBound(tabl, 2)

For Each nr In nrKolumn

a = 2

For i = 2 To xMax

For j = xMax To a Step -1

If CzyRosnaco Then

If tabl(j - 1, nr) > tabl(j, nr) Then

For jTbl = 1 To yMax

Temp = tabl(j - 1, jTbl)

tabl(j - 1, jTbl) = tabl(j, jTbl)

tabl(j, jTbl) = Temp

End If

Else

If tabl(j - 1, nr) < tabl(j, nr) Then

For jTbl = 1 To yMax

Temp = tabl(j - 1, jTbl)

tabl(j - 1, jTbl) = tabl(j, jTbl)

tabl(j, jTbl) = Temp

End If

a = a + 1

SortowanieBabelkoweV = tabl

End Function

Naszą formułe rozbudujemy o koleją funkcję..

=DefPozaTbl(SortowanieBabelkoweV(DanePodWarunkiem(A2:E21;VBALike(E2:E21;"*401*"));FAŁSZ;4))

Test3

332,76

500-09-401-15

Test5

294,01

500-09-401-07

Test12

257,1

500-02-401-06

Test6

51,89

500-04-401-12

Możemy też potrzebować sortować dane, czy część danych po wierszu/wierszach

Przyda się funkcja Sortowania w poziomie - SortowanieBabelkoweH

Sortowanie bąbelkowe tablicy 2D Horizontal po wielu wierszach

Public Function SortowanieBabelkoweH(rngDane As Variant, _

CzyRosnaco As Boolean, _

ParamArray nrWiersza() As Variant) As Variant

Dim tabl As Variant

Dim nr As Variant

Dim xMax As Long, yMax As Integer, jTbl As Integer

Dim i As Long, j As Long, a As Long

Dim Temp

tabl = rngDane

xMax = UBound(tabl, 1): yMax = UBound(tabl, 2)

For Each nr In nrWiersza

a = 2

For i = 2 To yMax

For j = yMax To a Step -1

If CzyRosnaco Then

If tabl(nr, j - 1) > tabl(nr, j) Then

For jTbl = 1 To xMax

Temp = tabl(jTbl, j - 1)

tabl(jTbl, j - 1) = tabl(jTbl, j)

tabl(jTbl, j) = Temp

End If

Else

If tabl(nr, j - 1) < tabl(nr, j) Then

For jTbl = 1 To xMax

Temp = tabl(jTbl, j - 1)

tabl(jTbl, j - 1) = tabl(jTbl, j)

tabl(jTbl, j) = Temp

End If

a = a + 1

SortowanieBabelkoweH = tabl

End Function

Formuła: =DefPozaTbl(SortowanieBabelkoweH(Transponuj2(DanePodWarunkiem(A2:D21;VBALike(E2:E21;"*401*")));PRAWDA;3))

Zwróci nam część danych pod warunkiem:

- DanePodWarunkiem(A2:D21;VBALike(E2:E21;"*401*"))

Dane Transponujemy i Sortujemy malejąco po trzecim wierszu.

Test12

Test3

Test5

Test6

257,1

332,76

294,01

51,89

Jednak nieraz dane nie są w jednym miejscu. Przydałaby się funkcja która stworzy jedną tablicę z wielu zestawów danych, żeby

inna funkcja mogła pracować na danych w kilku miejscach tak jakby był to jeden zakres.

Po to powstały funkcje tblUnionZakresowV i tblUnionZakresowH

Public Function tblUnionZakresowV(ParamArray Zakresy() As Variant) As Variant

Dim zakres As Variant

Dim wTbl As Long, kTbl As Integer

Dim tblWyniki() As Variant, w As Long

Dim vDane As Variant, iTbl As Long, jTbl As Integer

Dim rngDane As Object

For Each zakres In Zakresy

With zakres

Select Case TypeName(zakres)

Case "Range":

Set rngDane = zakres

With rngDane

wTbl = wTbl + .Rows.Count

If kTbl < .Columns.Count Then kTbl = .Columns.Count

End With

Set rngDane = Nothing

Case "Variant()"

wTbl = wTbl + UBound(zakres, 1)

If kTbl < UBound(zakres, 2) Then kTbl = UBound(zakres, 2)

Case Else

wTbl = wTbl + 1

End Select

End With

ReDim tblWyniki(1 To wTbl, 1 To kTbl)

For Each zakres In Zakresy

vDane = zakres

If IsArray(vDane) Then

For iTbl = LBound(vDane, 1) To UBound(vDane, 1)

w = w + 1

For jTbl = LBound(vDane, 2) To kTbl

If jTbl <= UBound(vDane, 2) Then

tblWyniki(w, jTbl) = vDane(iTbl, jTbl)

Else

tblWyniki(w, jTbl) = vbNullString

End If

Else

w = w + 1

tblWyniki(w, 1) = IIf(IsEmpty(vDane), vbNullString, vDane)

For jTbl = 2 To kTbl

tblWyniki(w, jTbl) = vbNullString

End If

tblUnionZakresowV = tblWyniki

End Function

Public Function tblUnionZakresowH(ParamArray Zakresy() As Variant) As Variant

Dim zakres As Variant

Dim wTbl As Long, kTbl As Integer

Dim tblWyniki() As Variant, k As Integer

Dim vDane As Variant, iTbl As Long, jTbl As Integer

Dim rngDane As Object

For Each zakres In Zakresy

With zakres

Select Case TypeName(zakres)

Case "Range":

Set rngDane = zakres

With rngDane

kTbl = kTbl + .Columns.Count

If wTbl < .Rows.Count Then wTbl = .Rows.Count

End With

Set rngDane = Nothing

Case "Variant()"

kTbl = kTbl + UBound(zakres, 2)

If wTbl < UBound(zakres, 1) Then wTbl = UBound(zakres, 1)

Case Else

kTbl = kTbl + 1

End Select

End With

ReDim tblWyniki(1 To wTbl, 1 To kTbl)

For Each zakres In Zakresy

vDane = zakres

If IsArray(vDane) Then

For jTbl = LBound(vDane, 2) To UBound(vDane, 2)

k = k + 1

For iTbl = 1 To wTbl

If iTbl <= UBound(vDane, 1) Then

tblWyniki(iTbl, k) = vDane(iTbl, jTbl)

Else

tblWyniki(iTbl, k) = vbNullString

End If

Else

k = k + 1

tblWyniki(1, k) = IIf(IsEmpty(vDane), vbNullString, vDane)

For iTbl = 2 To wTbl

tblWyniki(iTbl, k) = vbNullString

End If

tblUnionZakresowH = tblWyniki

End Function

Poniżej naszych danych stwórzmy ich "dalszy ciąg".

Test1

240,42

500-06-405-18

Test2

375,67

500-04-406-16

Test3

72,15

500-07-403-18

Test4

257,1

500-09-401-07

Test5

301,21

500-10-403-03

Test6

102,32

500-06-405-18

Test7

398,88

500-04-406-16

Test8

398,88

500-07-403-18

Teraz chcielibyśmy wiedzieć jaka jest sumaryczna wartość (kol.Wart) jeżeli kol.Test jest "Like" A*

=SUMA.ILOCZYNÓW(VBALike(tblUnionZakresowV(B2:B21;B24:B31);"A*")*(tblUnionZakresowV(D2:D21;D24:D31)))

Może się jednak okazać że "proste" Like nam nie wystarczy. Czasem najłatwiej jest coś określić wyrażeniami regularnymi. Do

Funkcje Użytkownika oparte o Wyrażenia Regularne

mojego dodatku dodam funkcje które do wykonania określonego zadania używają właśnie RegExp, no i, co nie obojętne, mogą

zwracać wyniki tablicowo.

Będzie to zestaw funkcji: Fragment_RegExp, Replace_RegExp, ZgodneZWzorcem_RegExp

Pierwszym przykładem wykorzystania będzie: Zwrócić dane z obu zakresów które w kol.Test mają "A1" lub "A2"

=DefPozaTbl(DanePodWarunkiem(tblUnionZakresowV(A2:E21;A24:E31);
ZgodneZWzorcem_RegExp(tblUnionZakresowV(B2:B21;B24:B31);"A(1|2)")))

Formuła zwróci..

Test1

323,35

500-09-405-00

Test4

318,31

500-04-406-19

Test7

119,48

500-08-405-17

Test1

240,42

500-06-405-18

Test4

257,1

500-09-401-07

Test7

398,88

500-04-406-16

Wyrażenia regularne mogą nam tez posłużyć do sortowania danych po kluczu określonym przez użytkownika..

Powiedzmy że chcemy posortować dane po kol.kod jednak nie po całej a po ostatnich dwóch liczbach tj np.: 500-07-403-18

Tablicę z trzecią liczbą kodów zwróci nam formuła =Fragment_RegExp(E2:E21;"\d+";3)

Tablicę z czwartą liczbą - analogiczna. Teraz jeżeli stworzymy poziomą unie zakresów i posortujemy ją po "dodatkowych"

kolumnach… :-) Formuła mogłaby wyglądać tak:

=SortowanieBabelkoweV(tblUnionZakresowH(A2:E21;Fragment_RegExp(E2:E21;"\d+";3);Fragment_RegExp(E2:E21;"\d+";4));
PRAWDA;7;6)

nie musimy zwracać wszystkich danych, wystarczy pięć pierwszych kolumn. Tj nasze dane źródłowe. Kolumny które zwracają

funkcje oparte o Reg.Exp z danymi "przyklejonymi" do naszych danych źródłowych mogą nie być zwrócone. W ten sposób te

dodatkowe kolumny pozostaną ukryte jednak będziemy mogli po nich sortować :-)

Formuła zwraca taki zestaw danych:

Test12

257,1

500-02-401-06

Test5

294,01

500-09-401-07

Test6

51,89

500-04-401-12

Test3

332,76

500-09-401-15

Test8

266,34

500-01-402-07

Test5

252,25

500-04-402-11

Test9

240,42

500-04-403-01

Test6

304,39

500-10-403-03

Test11

72,15

500-04-403-11

Test1

301,21

500-00-403-12

Test4

218,78

500-07-403-18

Zauważcie w jaki sposób posortowane są dane - jak rosną kody w części dotyczącej zadania ;-)

Następną grupą funkcji są funkcji dotyczące unikatów i ich ilości.

Ich szerszy opis wraz z przykładami wykorzystania można przejrzeć w artykułach na stronie www.excelperfect.pl

Unikaty excelperfect.pl

zmieniam jedynie podejście do definiowania zakresu poza tablicą wyników.

Public Function Unikaty(rngDane As Variant) As Variant

Dim tblDane As Variant, iTbl As Long, vItem As Variant

Dim colUnikaty As New VBA.Collection

Dim tblWyniki() As Variant, w As Long

tblDane = rngDane

On Error Resume Next

For iTbl = 1 To UBound(tblDane)

vItem = tblDane(iTbl, 1)

If Len(vItem) > 0 Then

colUnikaty.Add Item:=vItem, _

Key:=CStr(vItem)

If Err.Number <> 0 Then

Err.Clear

Else

w = w + 1

ReDim Preserve tblWyniki(1 To 1, 1 To w)

tblWyniki(1, w) = vItem

End If

On Error GoTo 0

If w > 0 Then

Unikaty = Transponuj2(tblWyniki)

End If

End Function

Public Function ileUnikatow(rngDane As Variant) As Variant

Dim tblDane As Variant, iTbl As Long, vItem As Variant

Dim colUnikaty As New VBA.Collection

tblDane = rngDane

On Error Resume Next

For iTbl = 1 To UBound(tblDane)

vItem = tblDane(iTbl, 1)

If Len(vItem) > 0 Then

colUnikaty.Add Item:=vItem, _

Key:=CStr(vItem)

End If

On Error GoTo 0

ileUnikatow = colUnikaty.Count

End Function

Public Function UnikatyPodWarunkiem(rngDane As Variant, _

vWarunki As Variant) As Variant

Dim tblDane As Variant, iTbl As Long, vItem As Variant

Dim colUnikaty As New VBA.Collection

Dim tblWyniki() As Variant, w As Long

tblDane = rngDane

On Error Resume Next

For iTbl = 1 To UBound(tblDane)

If vWarunki(iTbl, 1) Then

vItem = tblDane(iTbl, 1)

colUnikaty.Add vItem, CStr(vItem)

If Err.Number = 0 Then

w = w + 1

ReDim Preserve tblWyniki(1 To 1, 1 To w)

tblWyniki(1, w) = tblDane(iTbl, 1)

Else

Err.Clear

End If

On Error GoTo 0

If w > 0 Then

UnikatyPodWarunkiem = Transponuj2(tblWyniki)

End If

End Function

Public Function ileUnikatowPodWarunkiem(rngDane As Variant, _

vWarunki As Variant) As Variant

Dim tblDane As Variant, iTbl As Long, vItem As Variant

Dim colUnikaty As New VBA.Collection

tblDane = rngDane

On Error Resume Next

For iTbl = 1 To UBound(tblDane)

If vWarunki(iTbl, 1) Then

vItem = tblDane(iTbl, 1)

colUnikaty.Add vItem, CStr(vItem)

End If

On Error GoTo 0

ileUnikatowPodWarunkiem = colUnikaty.Count

End Function

Public Function UnikatowyRekord(rngDane As Variant, _

ParamArray nrKol() As Variant) As Variant

Dim nr As Variant, bFlaga As Boolean

Dim tblDane As Variant, iTbl As Long, jTbl As Integer, strItem As String

Dim colUnikaty As New VBA.Collection

Dim tblWyniki() As Variant, w As Long, k As Integer

tblDane = rngDane: k = UBound(tblDane, 2)

If IsMissing(nrKol()) Then bFlaga = True

On Error Resume Next

For iTbl = 1 To UBound(tblDane, 1)

If Not bFlaga Then

For Each nr In nrKol

strItem = strItem & tblDane(iTbl, nr)

Else

For jTbl = 1 To k

strItem = strItem & tblDane(iTbl, jTbl)

End If

colUnikaty.Add strItem, strItem

If Err.Number <> 0 Then

Err.Clear

Else

w = w + 1

ReDim Preserve tblWyniki(1 To k, 1 To w)

For jTbl = 1 To k

tblWyniki(jTbl, w) = tblDane(iTbl, jTbl)

End If

strItem = vbNullString

On Error Resume Next

If w > 0 Then

UnikatowyRekord = Transponuj2(tblWyniki)

End If

End Function

Sprawdźmy jeszcze szybkość działania tych funkcji wywoływanych poprzez dodatek automatyzacji a wprost z projektu VBA.

Teoretycznie funkcje wywoływane z takiego dodatku powinny być szybsze. Dodatek ten to skompilowana biblioteka dll, żeby

działała funkcja z VBA musi być najpierw przetłumaczona "na język maszyn" a dopiero następnie wykonana. Sprawdźmy zatem

jak to wygląda w praktyce..

Do testów posłuży nam procedura…

Option Explicit

Declare Function GetTickCount Lib "Kernel32" () As Long

Sub test()

Dim objCls As Object 'tkCOMAddIn.clsUDF

Dim tbl() As Variant, tblWar() As Variant

Dim i As Long, iMax As Long: iMax = 1000

Dim tblWyn1 As Variant, tblWyn2 As Variant

ReDim tbl(1 To iMax, 1 To 5): ReDim tblWar(1 To iMax, 1 To 1)

For i = 1 To iMax

tbl(i, 1) = i

tbl(i, 2) = Chr(Int((66 - 64 + 1) * Rnd + 64)) & Int(Rnd * 5)

tbl(i, 3) = "test" & i Mod 10

tbl(i, 4) = Round(Rnd * 400, 2)

tbl(i, 5) = Round(Rnd * 400, 2)

tblWar(i, 1) = tbl(i, 2)

Dim s1 As Single: s1 = GetTickCount

tblWyn1 = SortowanieBabelkoweVA(DanePodWarunkiemA(tbl, VBALikeA(tblWar, "A*")), True, 5, 4)

Debug.Print "VBA: " & (GetTickCount - s1) / 1000 & " s"

Set objCls = CreateObject("tkCOMAddIn.clsUDF")

With objCls

Dim s2 As Single: s2 = GetTickCount

tblWyn2 = .SortowanieBabelkoweV(.DanePodWarunkiem(tbl, .VBALike(tblWar, "A*")), True, 5, 4)

Debug.Print "DLL: " & (GetTickCount - s2) / 1000 & " s"

End With

Set objCls = Nothing

End Sub

Funkcje z "dopiskiem A" to odpowiedniki funkcji zapisanych w dodatku które są napisane w drugim module standardowym.

tblWyn1 = SortowanieBabelkoweVA(DanePodWarunkiemA(tbl, VBALikeA(tblWar, "A*")), True, 5, 4)

Procedura tworzy tablicę 1 to iMax, 1 to 5, wyciąga z nich ~1/3 danych tworząc dynamiczną tablicę którą transponuje, a następnie

dwa razy sortuje po kolumnach 4,5. Roboty zatem trochu ma. Wyniki dla 5 testów podane w sekundach.

iMax = 1000

iMax = 5000

iMax = 10000

VBA

DLL

VBA

DLL

VBA

DLL

0,265

0,173

6,161

4,072

23,978

15,82

0,279

0,171

6,255

4,149

23,901

16,038

0,313

0,188

5,696

3,791

23,041

15,212

0,249

0,141

5,819

3,868

22,886

15,212

0,297

0,173

6,006

3,976

24,461

16,147

60,30%

66,33%

66,32%

Jak widać procedury zapisane pliku dll wykonują zadanie w 60/66% czasu który byłby potrzebny do zrealizowania zadania poprzez

VBA. Więc choćby z tego powodu warto zastanowić się nad przenosinami na dodatki automatyzacji.