Klexys Musterdatei-Anonymisator
29.03.2018 19:15:00
Klexy
Dies ist keine Problemstellung, sondern ein Vorschlag oder so, zu dem ich gern die Meinung der Gemeinde hören würde, auf dass diese sich über die Osterfeiertage nicht langweile.
Hajo_Zi fordert mit Recht immer wieder das Hochladen einer Original-Datei und schlägt zum Anonymisieren die Lösung aus diesem Link vor:
http://www.ms-office-forum.de/forum/showthread.php?t=322895
Die Art, wie das dortige Makro die Daten anonymisiert, gefällt mir aber nicht, weil stur alles anonymisiert wird inkl. der Kopfzeilen (wenn man nicht entsprechend markiert, was relativ umständlich ist) und inkl. der Leerzeichen (was mich stört, weil jetzt alles eine Zeichenwurscht ist). Und identische Einträge werden nicht identisch anonymisiert, was in bestimmten Fällen meiner Meinung nach störend ist.
Daher stelle ich hier mal meinen eigenen Anonymisator zur Verfügung und Debatte. Er braucht zwar etwas länger, aber nicht wirklich störend.
Sub Klexys_Musterdatei_Anonymisator()
AktivesMakro_o = AktivesMakro
AktivesMakro = "Klexys_Musterdatei_Anonymisator"
Dim Wo_Kopfzeile As Variant, Hier_Kopfzeile As Range, Spaltenkopf As Range, Kopfzeile As _
Integer, Kopfspalte As Integer, letzte_Zeile As Integer
Dim AnoBereich As Range, AnoKopf As Range, s As Integer, Teilbereich As Range, Kombination _
As Range, AnzahlZellen As Integer
' Hinweise:
' Dieses Makro anonymisiert kritische Spalten in Dateien, die als Musterdateien in Excel- _
Foren hochgeladen werden sollen.
' Es ist empfehlenswert, eine anonymisierte Originaldatei statt einem schematischen _
Nachbau hochzuladen, denn
' 1. ist das Anonymisieren schneller und einfacher
' 2. vergisst man beim Nachbau mit Sicherheit essenzielle Teile, die dann zu falschen _
oder fehlenden Lösungen führen.
' Es ist empfehlenswert, nur wirklich heikle Zellen/Spalten zu anonymisieren und nicht _
die komplette Tabelle.
' Je mehr Daten anonymisiert werden, desto eher kann Datenmüll in der Musterdatei _
entstehen.
' Wirkungsweise:
' Das Makro fragt zu Beginn ab, in welcher Zeile die Spaltenköpfe sind und anonymisiert _
diese nicht.
' Die Zeichen werden durch andere Zeichen mit annähernd gleicher Breite (in Arial) _
ersetzt,
' damit die Befüllung der Zellen möglichst identisch bleibt (was nur optisch-formativen _
Gründen dient).
' Die Ziffer 1 wird nicht ersetzt, weil sie oft eine besondere Bedeutung hat.
' Die Ziffer 0 wird auch nicht ersetzt, weil sie oft eine besondere Bedeutung hat.
' Im anonymisierten Bereich gibt es dann nur noch
' die Ziffern 0, 1, 2 und 3
' die Vokale a, e, E, und I
' die Konsonanten b, c, m, t, B, D, N und M
' Das sollte im Normalfall genügend Anonymisierung sein.
' Anleitung:
' zu anonymisierende Zellen (oder ganze Spalten) markieren und Makro laufen lassen
' !!! Zellen mit FORMELN dürfen NICHT anonymisiert werden, sonst werden die Formeln zerstö _
rt
' !!! Zellen mit eindeutigen SCHLÜSSELWERTEN oder LAUFENDEn NUMMERN (d.h. Matchcodes, _
Kundennummern o.ä.)
' dürfen NICHT anonymisiert werden, weil sie sonst alle gleich lauten und ihre Schlü _
ssel-Funktionalität einbüßen,
' was bei manchen Formeln (z.B. SVERWEIS) zu Datenmüll im Ergebnis führen kann.
' !!! DATUMSSPALTEN sollten NICHT anonymisiert werden weil s.o.
' !!! Spaltenköpfe sollten im Sinne der Verständlichkeit NICHT anonymisiert werden. _
Deshalb wird die Spaltenzeile abgefragt.
Vonvorne:
On Error Resume Next
Wo_Kopfzeile = InputBox(vbCr & vbCr & "in welcher Zeile sind die Spaltenköpfe?" & _
vbCr & "", "Spaltenköpfe sollen im Klartext bleiben")
If IsNumeric(Wo_Kopfzeile) Then
If Wo_Kopfzeile * 1 = Int(Wo_Kopfzeile) Then
GoTo Losgehts
Else
MsgBox vbCr & _
"Es muss eine Ganzzahl eingegeben werden!" & vbCr & _
"Los, nochmal!" & vbCr & _
vbCr & vbCr & _
" _
_________________________________________________________________________" & vbCr & _
" Makro: _" & AktivesMakro & "_ "
GoTo Vonvorne
End If
Else
MsgBox vbCr & _
"Es muss eine Ganzzahl eingegeben werden!" & vbCr & _
"Los, nochmal!" & vbCr & _
vbCr & vbCr & _
"_________________________________________________________________________" _
& vbCr & _
" Makro: _" & AktivesMakro & "_ "
GoTo Vonvorne
End If
Losgehts:
Set Hier_Kopfzeile = Rows(Wo_Kopfzeile)
letzte_Zeile = ActiveSheet.UsedRange.Rows.Count
Set AnoBereich = Intersect(ActiveSheet.UsedRange, Selection).Cells
Set AnoKopf = Intersect(AnoBereich, Hier_Kopfzeile).Cells
For Each Spaltenkopf In AnoKopf
Kopfzeile = Spaltenkopf.Row
Kopfspalte = Spaltenkopf.Column
If Spaltenkopf.Row > 1 Then
Set Teilbereich = Range(Cells(1, Kopfspalte), Cells(Kopfzeile - 1, Kopfspalte))
If s = 0 Then ' Durchlaufzähler für die Teilbereiche
Set Kombination = Teilbereich
Else
Set Kombination = Union(Kombination, Teilbereich)
End If
Set Teilbereich = Range(Cells(Kopfzeile + 1, Kopfspalte), Cells(letzte_Zeile, _
Kopfspalte))
Set Kombination = Union(Kombination, Teilbereich)
s = s + 1
Else
Set Teilbereich = Range(Cells(2, Kopfspalte), Cells(letzte_Zeile, Kopfspalte))
If s = 0 Then
Set Kombination = Teilbereich
Else
Set Kombination = Union(Kombination, Teilbereich)
End If
s = s + 1
End If
Next Spaltenkopf
Kombination.Select
AnzahlZellen = Kombination.Count
' Ziffern
Selection.Replace What:="4", Replacement:="2", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="5", Replacement:="3", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="6", Replacement:="2", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="7", Replacement:="3", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="8", Replacement:="2", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="9", Replacement:="3", LookAt:=xlPart, MatchCase:=True
' Kleinbuchstaben
Selection.Replace What:="ä", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="d", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="e", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="f", Replacement:="t", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="g", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="h", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="j", Replacement:="i", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="k", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="l", Replacement:="i", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="n", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="o", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="ö", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="p", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="q", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="r", Replacement:="t", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="s", Replacement:="c", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="u", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="ü", Replacement:="b", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="v", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="w", Replacement:="m", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="x", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="y", Replacement:="a", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="z", Replacement:="c", LookAt:=xlPart, MatchCase:=True
' Großbuchstaben
Selection.Replace What:="A", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ä", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="C", Replacement:="B", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="F", Replacement:="E", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="G", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="H", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="J", Replacement:="I", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="K", Replacement:="B", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="L", Replacement:="I", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="O", Replacement:="N", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ö", Replacement:="N", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="P", Replacement:="B", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Q", Replacement:="N", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="R", Replacement:="B", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="S", Replacement:="E", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="T", Replacement:="E", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="U", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Ü", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="V", Replacement:="D", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="W", Replacement:="M", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="X", Replacement:="B", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Y", Replacement:="E", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="Z", Replacement:="E", LookAt:=xlPart, MatchCase:=True
MsgBox "Feddisch!" & vbCr & vbCr & "Es wurden " & Kombination.Count & " Zellen in " & _
ActiveSheet.UsedRange.Rows.Count - 1 & " Zeilen und " & AnoKopf.Count & " Spalten _
anonymisiert."
AktivesMakro = AktivesMakro_o
End Sub