Zwei Makros nebst ihren Hilfsmakros, die ich schon lange mal brauchte und endlich zusammengebastelt habe, stelle ich hier online. Manchmal funktionieren die auch nicht richtig, aber ein Anfang ist gemacht.
Ziel der Makros ist es, zwei Tabellen anzugleichen bzw. zu vergleichen
Das Angleich-Makro vergleicht jeweils eine auszuwählende Spalte zweier Tabellen und fügt Leerzeilen ein, wenn in einer der Tabellen ein Eintrag fehlt. Vorher wird sortiert, weil sonst Mist herauskommen muss.
Das Vergleichsmakro vergleicht zwei ganze Tabellen und markiert alle Zellen, die unterschiedlich sind, in der zweiten Tabelle gelb. Gab es Unterschiede, wird zudem in Tabelle 2 die erste Zelle rot markiert, sonst grün.
Die Makros kann man hier herunterladen als Textdatei und als
ODS-Datei.
Quellen: viele viele Internetseiten, besonders zu erwähnen:
Tabellenvergleich: http://de.openoffice.info/viewtopic.php?p=28758… von User „kannenklaus“
RangeSelection: https://forum.openoffice.org/en/forum/viewtopic.php?p=365582… Datei von User „FJCC“
REM Sortieren: Dokument „OpenOffice.org Macros Explained.odt“ von Andrew Pitonyak, Kapitel 5.4.13
Hier sind die Makros zum Lesen – da sie einfach ins HTML kopiert sind, weiß ich nicht, ob copy-paste klappen wird.
REM ***** BASIC *****
sub Tabellen_Umbenennen
oDoc = thisComponent
for i = 0 to oDoc.sheets.getCount()-1
altname = oDoc.sheets(i).name
altname = altname & "_alt"
oDoc.sheets(i).name = altname
next
MsgBox ("Kopieren: Alle markieren, dann Menü Tabelle > Tabelle verschieben/kopieren; Geht nicht mit allen Tabellen per Rechtsklick, weil dabei die Markierung verloren geht.")
end sub
REM --- KOPIEREN: ALLE MARKIEREN, DANN MENÜ TABELLE, TABELLE VERSCHIEBEN/KOPIEREN, REST DENKEN ;-)
Sub Alle_Tabellen_Vergleichen
'--Variablen für den Tabellenvergleich
Dim oDoc as Object
Dim oDocB as Object
Dim oShFehler as Object
Dim oAllSheetsA as Object
Dim oAllSheetsB as Object
Dim oSh1 as Object
Dim oSh2 as Object
Dim oCurSp1 as Object
Dim oCurZe1 as Object
Dim oCurSp2 as Object
Dim oCurZe2 as Object
Dim oCell1 as Object
Dim oCell2 as Object
Dim oCellDoku1 as Object
Dim oCellDoku2 as Object
Dim oView as Object 'für den View
Dim oCellInfo as Object
Dim oCellUeber as Object
Dim oRange1 as Object
Dim oRange2 as Object
Dim oSpalte as Object 'Spaltenüberschrift der Reportabelle
Dim intMaxZe as Integer
Dim intMaxSp as Integer 'Zähler für die max. Zeilen- bzw. Spaltenzahl
Dim intSp as Integer
Dim intZe as Integer 'Zähler für Spalten- und Zeilenanfang
Dim geaendert as Integer
Dim mastername as String
Dim vergleichname as String
Dim testname as String
' ### hier erzeugt er die Datei-Variable
oDoc = ThisComponent
' strRep = "Report abweichende Einträge"
'--Referenzieren bzw. Objekte erzeugen
' oShFehler = oDoc.Sheets.getByName(strRep)
' ### hier erzeugt er die Tabellen-Variablen
' ### für meine Änderungen: oSh1 soll die alte, oSh2 die neue Version sein => in oSh2 anfärben
for x = 0 to oDoc.sheets.getCount()-1
oSh1 = oDoc.Sheets(x)
mastername = oSh1.name
vergleichname = mastername & "_alt"
for y = 0 to oDoc.sheets.getCount()-1
oSh2 = oDoc.Sheets(y)
testname = oSh2.name
if (testname = vergleichname) AND (x <> y) then
' //passenden Tabellennamen gefunden, jetzt vergleichen:
' MsgBox (mastername & " wird mit " & vergleichname & " verglichen")
' MsgBox (x & " wird mit " & y & " verglichen")
oAllSheets = oDoc.Sheets
oSh1 = oAllSheets.getByName(vergleichname)
oSh2 = oAllSheets.getByName(mastername)
'###ori: oSh2 = oDoc.Sheets(2)
oCurSp1 = oSh1.createCursor 'Spaltenzähler für Blatt 1
oCurZe1 = oSh1.createCursor 'Zeilenzähler für Blatt 1
oCurSp2 = oSh2.createCursor 'Spaltenzähler für Blatt 2
oCurZe2 = oSh2.createCursor 'Zeilenzähler für Blatt 2
'--Cursor für das 1. Blatt erzeugen
oCurSp1.gotoEndofUsedArea(true)
oCurSp1.Columns.Count
oCurZe1.gotoEndOfUsedArea(True)
oCurZe1.Rows.Count
' MsgBox("Das Blatt "+oSh1.name +" hat "+oCurSp1.Columns.Count+" Spalten")
' MsgBox("Das Blatt "+oSh1.name +" hat "+oCurZe1.Rows.Count+" Zeilen")
'--Cursor für das 2. Blatt erzeugen
oCurSp2.gotoEndofUsedArea(true)
oCurSp2.Columns.Count
oCurZe2.gotoEndOfUsedArea(True)
oCurZe2.Rows.Count
' MsgBox("Das Blatt "+oSh2.name + " hat "+oCurSp2.Columns.Count+" Spalten")
' MsgBox("Das Blatt "+oSh2.name + " hat "+oCurZe2.Rows.Count+" Zeilen")
'--maximale Zeilenzahl ermitteln
If oCurSp1.Columns.Count > oCurSp2.Columns.Count then
intMaxSp = oCurSp1.Columns.Count
' msgbox(intMaxSp)
Else
intMaxSp = oCurSp2.Columns.Count
' msgbox(intMaxSp)
End if
'--maximale Zeilenenzahl ermitteln
If oCurZe1.Rows.Count > oCurZe2.Rows.Count then
intMaxZe = oCurZe1.Rows.Count
Else
intMaxZe = oCurZe2.Rows.Count
End if
'--Tabellenvergleich durchführen
i = 1
' Zwei For/next-Schleifen, um Zellen der beiden Tabellenblätter vergleichen
geaendert = 0
For intSp = 0 to intMaxSp-1 '-1, da EndofArea zur nächsten nicht benutzten Spalte geht
For intZe = 0 to intMaxZe-1 '-1, da EndofUsedArea zur nächsten nicht benutzten Zeile geht
oCell1 = oSh1.getCellByPosition(intSp,intZe)
oCell2 = oSh2.getCellByPosition(intSp, intZe)
If oCell1.String <> oCell2.String then
'If StrComp(oCell1.string, oCell2.string)<> 0 then
'--abweichende Werte des ersten Blattes eintragen
geaendert = 1
oCell2.CellBackColor = RGB(255,255,0)
i = i+1
End if
next intZe
next intSp
oCell2 = oSh2.getCellByPosition(0, 0)
if geaendert = 1 then
oCell2.CellBackColor = RGB(255,0,0)
else
oCell2.CellBackColor = RGB(0,255,0)
end if
end if '//von passenden Tabellennamen gefunden
next y
next x
MsgBox ("FERTIG")
End Sub
Sub Tue_Zeilen_angleichen(tabeins as string, tabzwei as string, idxeins as integer, idxzwei as integer)
'MsgBox (tabeins & tabzwei & idxeins & idxzwei)
'--Variablen für den Tabellenvergleich
Dim oDoc as Object
Dim oDocB as Object
Dim oShFehler as Object
Dim oAllSheetsA as Object
Dim oAllSheetsB as Object
Dim oSh1 as Object
Dim oSh2 as Object
Dim oCurSp1 as Object
Dim oCurZe1 as Object
Dim oCurSp2 as Object
Dim oCurZe2 as Object
Dim oCell1 as Object
Dim oCell2 as Object
Dim oCellDoku1 as Object
Dim oCellDoku2 as Object
Dim oView as Object 'für den View
Dim oCellInfo as Object
Dim oCellUeber as Object
Dim oRange1 as Object
Dim oRange2 as Object
Dim oSpalte as Object 'Spaltenüberschrift der Reportabelle
Dim intMaxZe as Integer
Dim intMaxSp as Integer 'Zähler für die max. Zeilen- bzw. Spaltenzahl
Dim intSp as Integer
Dim intZe as Integer 'Zähler für Spalten- und Zeilenanfang
Dim geaendert as Integer
Dim mastername as String
Dim vergleichname as String
Dim testname as String
Dim vglerg as Integer
oDoc = ThisComponent
oAllSheets = oDoc.Sheets
oSh1 = oAllSheets.getByName(tabeins)
oSh2 = oAllSheets.getByName(tabzwei)
oCurSp1 = oSh1.createCursor 'Spaltenzähler für Blatt 1
oCurZe1 = oSh1.createCursor 'Zeilenzähler für Blatt 1
oCurSp2 = oSh2.createCursor 'Spaltenzähler für Blatt 2
oCurZe2 = oSh2.createCursor 'Zeilenzähler für Blatt 2
'--Cursor für das 1. Blatt erzeugen
oCurSp1.gotoEndofUsedArea(true)
oCurSp1.Columns.Count
oCurZe1.gotoEndOfUsedArea(True)
oCurZe1.Rows.Count
'--Cursor für das 2. Blatt erzeugen
oCurSp2.gotoEndofUsedArea(true)
oCurSp2.Columns.Count
oCurZe2.gotoEndOfUsedArea(True)
oCurZe2.Rows.Count
'--maximale Zeilenzahl ermitteln
If oCurSp1.Columns.Count > oCurSp2.Columns.Count then
intMaxSp = oCurSp1.Columns.Count
' msgbox(intMaxSp)
Else
intMaxSp = oCurSp2.Columns.Count
' msgbox(intMaxSp)
End if
'--maximale Zeilenenzahl ermitteln
If oCurZe1.Rows.Count > oCurZe2.Rows.Count then
intMaxZe = oCurZe1.Rows.Count
Else
intMaxZe = oCurZe2.Rows.Count
End if
'--Tabellenvergleich durchführen
' geaendert = 0
' nur Indexspalte! For intSp = 0 to intMaxSp-1 '-1, da EndofArea zur nächsten nicht benutzten Spalte geht
intSp = 0
intZe = 0
Do
oCell1 = oSh1.getCellByPosition(idxeins,intZe)
oCell2 = oSh2.getCellByPosition(idxzwei, intZe)
vglerg = StrComp(oCell1.string, oCell2.string, 0)
if vglerg = 1 then ' 1=Text1 ist später im Alphabet => Zeile in Tabelle1 einfügen
oSh1.Rows.insertByIndex(intZe,1)
elseif vglerg = -1 then ' -1=Text2 ist später im Alphabet => Zeile in Tabelle2 einfügen
oSh2.Rows.insertByIndex(intZe,1)
end if
' geaendert = 1
intZe = intZe+1
Loop Until intZe = intMaxZe
' oCell2 = oSh2.getCellByPosition(0, 0)
' if geaendert = 1 then
' oCell2.CellBackColor = RGB(255,0,0)
' else
' oCell2.CellBackColor = RGB(0,255,0)
' end if
' MsgBox ("FERTIG")
End Sub
Private sRangeSelection$,bRangeSelecting As Boolean
function getRangeSelection() as String
oController = ThisComponent.CurrentController
sTitle = "Zelle auswählen, keinen Bereich"
bAutoClose = True
sInitial = "A1"
'Dim oDoc as Object
Dim oListener as Object
Dim aProps(2) As New com.sun.star.beans.PropertyValue
oListener = createUnoListener("RangeSelection_","com.sun.star.sheet.XRangeSelectionListener") 'create a listener
oController.addRangeSelectionListener(oListener) 'register the listener
aProps(0).Name = "InitialValue"
aProps(0).Value = sInitial
aProps(1).Name = "Title"
aProps(1).Value = sTitle
aProps(2).Name = "CloseOnMouseRelease"
aProps(2).Value = bAutoClose
With oController.getFrame
'this is required when calling from IDE or other frame in order to avoid endless loop
.activate
.getContainerWindow.toFront
End With
bRangeSelecting = True
oController.startRangeSelection(aProps())
while bRangeSelecting
wait 1000
Wend
oController.removeRangeSelectionListener(oListener)
getRangeSelection = sRangeSelection
End function
Sub RangeSelection_done(oEv)
sRangeSelection = oEv.RangeDescriptor
bRangeSelecting = false
End Sub
Sub RangeSelection_aborted(oEv)
sRangeSelection = ""
bRangeSelecting = false
End Sub
Sub RangeSelection_disposing(oEv)
End Sub
function Auswahl() as String
Dim oDoc as Object
Dim RangeAsText as String
Dim Tabellenname as String
Dim Spalte as String
Dim pos as Integer
Dim oCurSp1 as Object
Dim oCurZe1 as Object
Dim intSp as Integer
Dim Spaltennummer as Integer
Dim oCell1 as Object
Dim Adresse as String
Dim Wiederbau as String
oDoc = ThisComponent
oAllSheets = oDoc.Sheets
RangeAsText = getRangeSelection()
'Alles ab dem Doppelpunkt abschneiden, falls vorhanden
pos = instr(RangeAsText,":")
if pos <> 0 then
RangeAsText = left(RangeAsText, pos-1)
end if
' MsgBox (RangeAsText)
'erstes $ abschneiden
Tabellenname = right(RangeAsText, Len(RangeAsText)-1)
'Tabellenname zwischen Anfang und .$
pos = instr(Tabellenname,".$")
Tabellenname = left(Tabellenname, pos-1)
'Tabellenname abschneiden und erstes $ gleich mit, vor Hochkommas weil pos dann neu belegt
Spalte = right(RangeAsText, Len(RangeAsText)-pos-2)
'Eventuelle Hochkommas abschneiden
pos = instr(Tabellenname,"'")
Wiederbau = Tabellenname
if pos <> 0 then 'Name in Hochkommas
Tabellenname = mid(Tabellenname, 2, len(Tabellenname)-2)
end if
'MsgBox (Tabellenname)
'Spalte exstrahieren, also alles bis zum nächsen $
pos = instr(Spalte,"$")
Spalte = left(Spalte, pos-1)
Spalte = "$" & Wiederbau & ".$" & Spalte & "$1"
'MsgBox (Spalte)
oSh1 = oAllSheets.getByName(Tabellenname)
oCurSp1 = oSh1.createCursor 'Spaltenzähler für Blatt 1
oCurZe1 = oSh1.createCursor 'Zeilenzähler für Blatt 1
oCurSp1.gotoEndofUsedArea(true)
oCurSp1.Columns.Count
oCurZe1.gotoEndofUsedArea(true)
intSp = 0
Do
oCell1 = oSh1.getCellByPosition(intSp,0)
Adresse = oCell1.AbsoluteName
'MsgBox (Adresse & "=" & Spalte)
if Adresse = Spalte then
Spaltennummer = intSp
end if
intSp = intSp+1
Loop Until intSp = oCurSp1.Columns.Count
Auswahl = Tabellenname & ":" & CStr(Spaltennummer)
End function
sub Zeilen_angleichen
dim eins as string
dim zwei as string
dim speins as integer
dim spzwei as integer
dim pos as integer
dim temp as string
MsgBox ("Index-Spalte in erster Tabelle durch Klick auf Zelle auswählen")
eins = Auswahl
pos = instr(eins,":")
temp = right(eins, len(eins)-pos)
speins = CInt(temp)
eins = left(eins, pos-1)
MsgBox ("Index-Spalte in zweiter Tabelle durch Klick auf Zelle auswählen")
zwei = Auswahl
pos = instr(zwei,":")
temp = right(zwei, len(zwei)-pos)
spzwei = CInt(temp)
zwei = left(zwei, pos-1)
if (eins <> zwei) then
Tue_Zeilen_angleichen(eins, zwei, speins, spzwei)
else
MsgBox ("Unterschiedliche Tabellenblätter im selben Dokument nötig")
end if
MsgBox ("FERTIG")
end sub