OpenOffice.info

von **Usch** » Mi, 08.11.2006 20:01

Hallo an alle,

selbst wenn ich jetzt mit einer unfreundlichen Zuschrift rechnen muß, so möchte ich doch noch eine letzte Bemerkung in diesen Thread stellen. Der in meiner ersten Zuschrift eingefügte Code sollte lediglich die von wagnerpa gestellte Aufgabe erfüllen, den Code in Analogie zu dem VBA-Code der Anfrage zu notieren, mehr nicht.
Darüberhinaus kann aber dieses einfache Beispiel zeigen, daß speziell bei interpretativ arbeitenden Diensten ein sorgfältiges Durchdenken des Programm-Algorithmus überlebenswichtig sein kann. Ich habe mir einmal den Spaß gemacht, einen Laufzeit-Test mit den beiden in diesem Thread abgebildeten Programmstücken sowie mit einem von mir neu geschriebenen Programm-Code (siehe unten) durchzuführen. Es wurde eine Datenmenge von 20000 Werten, davon etwa 6700 verschiedene Werte, mit einer ungünstigen Verteilung angelegt (durchschnittlich kommt also jeder Wert etwa 3mal vor). Bei allen Durchläufen wurde, um gleiche Bedingungen zu erzeugen, OpenOffice neu gestartet. Die Ergebnisse waren insofern erstaunlich, daß der von Karolus gelieferte Code sogar 20 Min. länger benötigte.
Folgende Zeiten wurden gemessen:
Original-VBA-(Excel-)Code: 15 Min. und 35 Sek.
1. Code von Usch 130 Min.
Code von Karolus 150 Min.
2. Code von Usch 1 Min. und 30 Sek.
Ich glaube, der letzte Messwert spricht Bände. Für mich war dieses Beispiel und seine Beschäftigung mit dessen Lösung eine starke Bereicherung in Sachen Erkenntnis. Nun - daß Excel bei vergleichbarem Lösungsverfahren die Nase vorn hat, liegt wohl daran, daß OpenOffice das Programm interpretierend verarbeitet, was aber nicht weiter störend ist. Es zwingt lediglich die Programmierer zu einer effektiven Gestaltung ihrer Algorithmen. Diese Erkenntnis habe ich aus diesem kleinen Beispiel gewonnen. Vielleicht möchte wagnerpa die Sache noch einmal selbst ausprobieren. Wenn sein Datenmaterial sehr umfangreich ist, würde ich es ihm sogar empfehlen. Deshalb unten noch einmal der verbesserte Programm-Code.

Herzliche Grüße

Usch

Code: Alles auswählen

REM  *****  BASIC  *****
Option Explicit

Public objD As Object
Public objSheet As Object, objZelle As Object
Public objS as Object
Public document   as object
Public dispatcher as object
Public args1(0) as new com.sun.star.beans.PropertyValue
Public args2(0) as new com.sun.star.beans.PropertyValue
Public args3(1) as new com.sun.star.beans.PropertyValue
Public Zeil as Integer

Sub Main
 objD=ThisComponent
'Application.ScreenUpdating=FALSE:
 objD.LockControllers
 

'Vorbelegungen für Prozeduren "Zaehlen" und "LetzteZelle":
 document   = objD.CurrentController.Frame
 dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
 args1(0).Name = "ToPoint"
 args2(0).Name = "StringName"
 args3(0).Name = "By"
 args3(0).Value = 1
 args3(1).Name = "Sel"
 args3(1).Value = false

' Aufruf der Algorithmus-Prozedur:
  Call ZaehlenUndLoeschen
 
'Application.ScreenUpdating=TRUE:
 objD.UnLockControllers
 
 objD=Nothing
 objS=Nothing
 objZelle=Nothing   
 objSheet=Nothing   
 document=Nothing
 dispatcher=Nothing
 
End Sub

REM *****************************************************
Sub ZaehlenUndLoeschen()
Dim I as Integer, P as Integer, S as String, N as Integer
 
 Call VorSort
 
 objSheet=objD.getCurrentController().ActiveSheet

 objZelle = objSheet.getCellRangeByName("A1")
 objD.CurrentController.select(objZelle)
 Call LetzteZelle
 objS=objD.getCurrentSelection()
 Zeil=objS.CellAddress.Row

    I = 1
    S=WL(I-1,0)
    While S <> ""
'    Realisierung der CountIf-Funktion - Eintragung der Anzahl als Wert in Spalte 2:   
     Call Zaehlen(I)
     objZelle=objSheet.getCellByPosition(1,I-1)
     n=objZelle.Value
     objZelle.FormulaLocal=N

     If N>1 Then
      Call ZeilenLoesch(I+1,I+N-1)     
     EndIf

     I = I + 1
     S=WL(I-1,0)
    Wend
   
  objZelle = objSheet.getCellRangeByName("A1")
  objD.CurrentController.select(objZelle)

End Sub

REM *****************************************************
Sub Zaehlen(I as Integer)

 args1(0).Value = "$B$" & I
 dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())

 args2(0).Value = "=ZÄHLENWENN(A1:A" & Zeil & ";A" & I & ")"
 dispatcher.executeDispatch(document, ".uno:EnterString", "", 0, args2())

End Sub

REM *****************************************************
Sub LetzteZelle

'Sprung nach erster Spalte in Zeile:
 dispatcher.executeDispatch(document, ".uno:GoLeft", "", 0, args3())
'Sprung nach letztem Wert in erster Spalte:
 dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args3())
'dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args3())
'dispatcher.executeDispatch(document, ".uno:GoUpToStartOfData", "", 0, args3())

End Sub


Sub VorSort
rem ----------------------------------------------------------------------
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "Sel"
args1(0).Value = false

dispatcher.executeDispatch(document, ".uno:GoToStart", "", 0, args1())

rem ----------------------------------------------------------------------
dim args2(1) as new com.sun.star.beans.PropertyValue
args2(0).Name = "By"
args2(0).Value = 1
args2(1).Name = "Sel"
args2(1).Value = true

dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args2())

rem ----------------------------------------------------------------------
dim args3(6) as new com.sun.star.beans.PropertyValue
args3(0).Name = "ByRows"
args3(0).Value = true
args3(1).Name = "HasHeader"
args3(1).Value = false
args3(2).Name = "CaseSensitive"
args3(2).Value = false
args3(3).Name = "IncludeAttribs"
args3(3).Value = true
args3(4).Name = "UserDefIndex"
args3(4).Value = 0
args3(5).Name = "Col1"
args3(5).Value = 1
args3(6).Name = "Ascending1"
args3(6).Value = true

dispatcher.executeDispatch(document, ".uno:DataSort", "", 0, args3())

rem ----------------------------------------------------------------------
dim args4(0) as new com.sun.star.beans.PropertyValue
args4(0).Name = "Sel"
args4(0).Value = false

dispatcher.executeDispatch(document, ".uno:GoToStart", "", 0, args4())

End Sub


Function WL(Z As Integer, S As Integer) As Variant
' Formel einer Zelle lesen:
  WL=objSheet.getCellByPosition(S,Z).FormulaLocal
End Function


sub ZeilenLoesch(ZA as Integer, ZE as Integer)
rem ----------------------------------------------------------------------
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ToPoint"
args1(0).Value = "$A$" & ZA & ":$A$" & ZE

dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())

rem ----------------------------------------------------------------------
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "Flags"
args2(0).Value = "R"

dispatcher.executeDispatch(document, ".uno:DeleteCell", "", 0, args2())

end sub

von **wagnerpa** » Mo, 06.11.2006 21:39

Super makro genau wie unter excel vielen dank für alles

von **Karolus** » So, 05.11.2006 19:40

Hallo

Dazu hätte ich dann folgenden Code anzubieten, ist zwar sehr viel aufgezeichneter Code, läuft aber deutlich schneller als Uschs Code.

Code: Alles auswählen

REM  *****  BASIC  *****


sub countanddeleteifdouble
dim document   as object
dim dispatcher as object

document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "ToPoint"
args2(0).Value = "A1"

dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args2())
dim args3(1) as new com.sun.star.beans.PropertyValue
args3(0).Name = "By"
args3(0).Value = 1
args3(1).Name = "Sel"
args3(1).Value = false

dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args3())

odoc = thisComponent
mysheet=odoc.currentcontroller.activesheet
Zellaktuell=odoc.getCurrentSelection().getCellAddress()
oRow=Zellaktuell.Row
oColumn=Zellaktuell.column

  myrows=mysheet.getrows
  mycolumns=mysheet.getcolumns

dim args4(0) as new com.sun.star.beans.PropertyValue
args4(0).Name = "ToPoint"
args4(0).Value = "B1"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args4())

dim args7(0) as new com.sun.star.beans.PropertyValue
args7(0).Name = "StringName"
args7(0).Value = "=ZÄHLENWENN(A1:A$" & orow+1 &";A1)"
dispatcher.executeDispatch(document, ".uno:EnterString", "", 0, args7())

dim args8(0) as new com.sun.star.beans.PropertyValue
args8(0).Name = "ToPoint"
args8(0).Value = "B1:B" & orow+1
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args8())
dispatcher.executeDispatch(document, ".uno:FillDown", "", 0, Array())
dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())

dim args11(0) as new com.sun.star.beans.PropertyValue
args11(0).Name = "ToPoint"
args11(0).Value = "C1"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args11())

dim args12(5) as new com.sun.star.beans.PropertyValue
args12(0).Name = "Flags"
args12(0).Value = "SVDNT"
args12(1).Name = "FormulaCommand"
args12(1).Value = 0
args12(2).Name = "SkipEmptyCells"
args12(2).Value = false
args12(3).Name = "Transpose"
args12(3).Value = false
args12(4).Name = "AsLink"
args12(4).Value = false
args12(5).Name = "MoveMode"
args12(5).Value = 4
dispatcher.executeDispatch(document, ".uno:InsertContents", "", 0, args12())

dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args4())

dim args5(0) as new com.sun.star.beans.PropertyValue
args5(0).Name = "StringName"
args5(0).Value = "=ZÄHLENWENN(A$1:A1;A1"
dispatcher.executeDispatch(document, ".uno:EnterString", "", 0, args5())
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args8())
dispatcher.executeDispatch(document, ".uno:FillDown", "", 0, Array())
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args4())
for i = orow to 0 step -1
countzell=mysheet.getCellByPosition(1,i)
counter = countzell.value
if counter > 1 then
 myrows.removebyindex(i,1)
 end if
 next i
 mycolumns.removebyindex(1,1)
end sub

Gruß Karo

von **Usch** » So, 05.11.2006 10:41

Hallo wagnerpa,

ich habe mir zu Deiner Anfrage einmal etwas ausgedacht. Es ist mein erster OOo-Programmierversuch. Er wird sicher so manchen Spezialisten zum Schmunzeln verleiten.
Es war gar nicht so leicht, die Sache zu programmieren, da Hilfen hier dünn gesät sind. Mit dem Developers Guide aus dem SDK ist auch nicht gut Kirschenessen. Und so habe ich denn einen Teil mit dem Makro-Rekorder, einen anderen Teil mit dem Wissen aus dem Artikel "Tabellen-Dirigent" der Zeitschrift c't, Nr. 17/2006, ab S. 192 erledigt. Alles in allem eine bunte Mischung.
Eine direkte Umsetzung des Codes schien nicht möglich zu sein. Ich habe den Algorithmus mit etwa 18500 Werten einmal in Excel und einmal in OOo gemessen: Excel brauchte etwa 15 Sek., OOo etwa 3 Minuten. Aber das ist wohl normal. Ich habe auch versucht, einiges zu "optimieren" (Vereinbarungen als "Public" und mehrfach verwendbar usw.). Der Effekt war aber kaum spürbar. Probiere es einfach einmal selber, vielleicht reicht es Dir.

Übrigens: Der Algorithmus funktioniert nur, wenn die nicht leeren Werte in Spalte 1 ohne Lücken abgespeichert sind! Das Start-Makro ist "Main".

Herzliche Grüße

Usch

Code: Alles auswählen

REM  *****  BASIC  *****
Option Explicit

Public objD As Object
Public objSheet As Object, objZelle As Object
Public objS as Object
Public document   as object
Public dispatcher as object
Public args1(0) as new com.sun.star.beans.PropertyValue
Public args2(0) as new com.sun.star.beans.PropertyValue
Public args3(1) as new com.sun.star.beans.PropertyValue
Public Zeil as Integer

Sub Main
 objD=ThisComponent
'Application.ScreenUpdating=FALSE:
 objD.LockControllers
 

'Vorbelegungen für Prozeduren "Zaehlen" und "LetzteZelle":
 document   = objD.CurrentController.Frame
 dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
 args1(0).Name = "ToPoint"
 args2(0).Name = "StringName"
 args3(0).Name = "By"
 args3(0).Value = 1
 args3(1).Name = "Sel"
 args3(1).Value = false

' Aufruf der Algorithmus-Prozedur:
  Call ZaehlenUndLoeschen
 
'Application.ScreenUpdating=TRUE:
 objD.UnLockControllers
 
 objD=Nothing
 objS=Nothing
 objZelle=Nothing   
 objSheet=Nothing   
 document=Nothing
 dispatcher=Nothing
 
End Sub

REM *****************************************************
Sub ZaehlenUndLoeschen()
Dim I as Integer, P as Integer, S as String, N as Integer
 
 objSheet=objD.getCurrentController().ActiveSheet

 objZelle = objSheet.getCellRangeByName("A1")
 objD.CurrentController.select(objZelle)
 Call LetzteZelle
 objS=objD.getCurrentSelection()
 Zeil=objS.CellAddress.Row

    I = 1
    objZelle=objSheet.getCellByPosition(0,I-1)
    S=objZelle.FormulaLocal
    While S <> ""
'    Realisierung der CountIf-Funktion - Eintragung der Anzahl als Wert in Spalte 2:    
     Call Zaehlen(I)
     objZelle=objSheet.getCellByPosition(1,I-1)
     n=objZelle.Value
     objZelle.FormulaLocal=N

'    Sprung zum letzten Wert in Spalte 1:
     Call LetzteZelle
     
     objS=objD.getCurrentSelection()
     N=objS.CellAddress.Row
     Zeil=N
      For P = (N+1) To (I+1) Step -1
       If objSheet.getCellByPosition(0,P-1).FormulaLocal=S Then
        objSheet.Rows.RemoveByIndex(P-1,1)
       End If
      Next P
     I = I + 1
     objZelle=objSheet.getCellByPosition(0,I-1)
     S=objZelle.FormulaLocal
    Wend
    
  objZelle = objSheet.getCellRangeByName("A1")
  objD.CurrentController.select(objZelle)

End Sub

REM *****************************************************
Sub Zaehlen(I as Integer)

 args1(0).Value = "$B$" & I
 dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())

 args2(0).Value = "=ZÄHLENWENN(A1:A" & Zeil & ";A" & I & ")"
 dispatcher.executeDispatch(document, ".uno:EnterString", "", 0, args2())

End Sub

REM *****************************************************
Sub LetzteZelle

'Sprung nach erster Spalte in Zeile:
 dispatcher.executeDispatch(document, ".uno:GoLeft", "", 0, args3())
'Sprung nach letztem Wert in erster Spalte:
 dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args3())
'dispatcher.executeDispatch(document, ".uno:GoDownToEndOfData", "", 0, args3())
'dispatcher.executeDispatch(document, ".uno:GoUpToStartOfData", "", 0, args3())

End Sub

von **wagnerpa** » Do, 02.11.2006 07:19

Morgen zusammen

Habe ein kleines Problem und zwar habe ich ein Excel VBA Makro und möchte es in OO Calc verwenden.
Da ich selber nicht so besonders in Makro schreiben bin, bitte ich um Hilfe das Makro mir umzustellen zu das ich es verwenden kann

Code: Alles auswählen

Sub ZählenUndLöschen()
Dim I&
Dim P&
    I = 1
    While Cells(I, 1) <> ""
        Cells(I, 2) = Application.WorksheetFunction.CountIf([A:A], Cells(I, 1))
        For P = [A65000].End(xlUp).Row To I + 1 Step -1
            If Cells(P, 1) = Cells(I, 1) Then
                Cells(P, 1).EntireRow.Delete
            End If
        Next P
    I = I + 1
    Wend
End Sub

OpenOffice.info

Ein VBA Makro umwandeln

Antwort erstellen

Ansicht erweitern Die letzten Beiträge des Themas: Ein VBA Makro umwandeln

Ein VBA Makro umwandeln