Office: Anonymisierung und Pseudonymisierung von Beispielmappen

chris-kaiser · 9. Juni 2015

Hi,
^^ Ok, stimmt danke
ich war wohl zu lange auf Urlaub...

Beibehaltung der Umsetzungstabelle je Datei
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

wird wohl schwer umzusetzen sein, da ja mit Absicht ein RND verwendet wird.
Eine Verschlüsselung die einen Algorithmus hat wäre wohl nicht zielführend.

Das mit textformatierten Zahlen werde ich mal anschauen.

chris-kaiser · 10. Juni 2015

Hi,

so....

Code:

Option Explicit

' Anonymisieren von Zellinhalten - developed by XLph 05/2015

Private mabytASCII_Encrypt(32 To 255) As Byte

Public Sub Anonymisieren_XLPH_V4()

Dim rngBereich As Range
Dim rngArea As Range

Dim avarData() As Variant
Dim lngDz As Long
Dim lngDs As Long

Dim lngAnzahlWerte As Long
Dim blnTextZiffernUmwandeln As Boolean

Dim varWert As Variant

Dim rng_cell As Range
Dim lngSpecialCellsValue As XlSpecialCellsValue

Dim lngZeile As Long
Dim lngSpalte As Long
Dim lngSchritte As Long
Dim rngBlock As Range

Dim lngCalculation_M As XlCalculation
Dim blnEnableEvents_M As Boolean

Dim DocProb As DocumentProperty
Dim wsh As Worksheet

Const conArrayGroesse As Long = 10000

On Error GoTo Fehlerbehandlung:

lngCalculation_M = Application.Calculation
blnEnableEvents_M = Application.EnableEvents

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False

If Not TypeOf Selection Is Range Then
Application.Calculation = lngCalculation_M
Application.EnableEvents = blnEnableEvents_M
MsgBox "Sie sollten zumindest eine Zelle markieren!", vbInformation: Exit Sub
End If

lngSpecialCellsValue = xlTextValues

If MsgBox("Sollen auch Datumswerte und Zahlen ersetzt werden?", _
vbYesNo, "Was soll alles ersetzt werden?") = vbYes Then
lngSpecialCellsValue = lngSpecialCellsValue + xlNumbers
End If

Set rngBereich = getCellConstants(Selection, lngSpecialCellsValue)

If rngBereich Is Nothing Then
Application.Calculation = lngCalculation_M
Application.EnableEvents = blnEnableEvents_M
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation: Exit Sub
End If

If MsgBox("Sollen auch Ziffern/Zahlen in Texten ersetzt werden?", _
vbYesNo, "Text-Zahlen ersetzen?") = vbYes Then
blnTextZiffernUmwandeln = True
End If

Call setASCII_Encryption(blnTextZiffernUmwandeln)

For Each rngArea In rngBereich.Areas

Randomize Timer

With rngArea

lngAnzahlWerte = WorksheetFunction.CountA(.Cells)

If lngAnzahlWerte > 0 Then

If .Rows.Count = 1 And .Columns.Count = 1 Then

.Value = getAnonymValue(.Value, blnTextZiffernUmwandeln)

ElseIf lngAnzahlWerte < conArrayGroesse Then

avarData() = .Value

For lngDz = LBound(avarData, 1) To UBound(avarData, 1)
For lngDs = LBound(avarData, 2) To UBound(avarData, 2)

avarData(lngDz, lngDs) = getAnonymValue(avarData(lngDz, lngDs), blnTextZiffernUmwandeln)

Next
Next

.Value = avarData()

Else

If .Rows.Count >= .Columns.Count Then

' zeilenweise abarbeiten

lngSchritte = conArrayGroesse \ .Columns.Count

For lngZeile = 1 To .Rows.Count Step lngSchritte

Set rngBlock = Intersect(.Rows(lngZeile).Resize(lngSchritte), .Cells)

avarData() = rngBlock.Value

For lngDz = LBound(avarData, 1) To UBound(avarData, 1)
For lngDs = LBound(avarData, 2) To UBound(avarData, 2)

avarData(lngDz, lngDs) = getAnonymValue(avarData(lngDz, lngDs), blnTextZiffernUmwandeln)

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

' Fortschritt anzeigen
Application.StatusBar = "Anonymisieren: " & Format(lngZeile / .Rows.Count, "0.0%")
DoEvents

Next

Else
' spaltenweise abarbeiten

lngSchritte = conArrayGroesse \ .Rows.Count

For lngSpalte = 1 To .Columns.Count Step lngSchritte

Set rngBlock = Intersect(.Columns(lngSpalte).Resize(, lngSchritte), .Cells)

avarData() = rngBlock.Value

For lngDz = LBound(avarData, 1) To UBound(avarData, 1)
For lngDs = LBound(avarData, 2) To UBound(avarData, 2)

avarData(lngDz, lngDs) = getAnonymValue(avarData(lngDz, lngDs), blnTextZiffernUmwandeln)

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

' Fortschritt anzeigen
Application.StatusBar = "Anonymisieren: " & Format(lngZeile / .Rows.Count, "0.0%")
DoEvents

Next

End If

End If

End If

End With
Next

For Each DocProb In ThisWorkbook.BuiltinDocumentProperties
DocProb.Value = 0
Next

For Each wsh In ActiveWorkbook.Worksheets
With wsh.PageSetup
.LeftHeader = " "
.CenterHeader = " "
.RightHeader = " "
.LeftFooter = " "
.CenterFooter = " "
.RightFooter = " "
End With
Next

Fehlerbehandlung:

If Err.Number > 0 Then
MsgBox "Fehler: " & Err.Number & String(2, vbLf) & _
Err.Description, vbCritical, "Anonymisieren_XLPH"
End If

Application.Calculation = lngCalculation_M
Application.EnableEvents = blnEnableEvents_M
Application.ScreenUpdating = True

' Fortschritt-Anzeige zurücksetzen
Application.StatusBar = False

Set rngArea = Nothing
Set rngBereich = Nothing

End Sub

Private Function getCellConstants(ByRef prngBereich As Range, ByVal plngSpecialCellsValue As XlSpecialCellsValue) As Range
On Error Resume Next
With prngBereich.Worksheet
Set getCellConstants = Union(Intersect(.UsedRange, prngBereich), .Cells(.Rows.Count, .Columns.Count)) _
.SpecialCells(xlCellTypeConstants, plngSpecialCellsValue)
Debug.Print getCellConstants.Address
End With
On Error GoTo 0
End Function

Private Sub setASCII_Encryption(ByVal blnTextZiffernUmwandeln As Boolean)

Dim lngI As Long
Dim lngR As Long

Dim abytTemp_1() As Byte
Dim abytTemp_2() As Byte
Dim bytTemp As Byte

Dim lngAnzahl As Long
Dim bytStartASCII_1 As Byte
Dim bytStartASCII_2 As Byte

Dim avarUmlauteGross As Variant
Dim avarUmlauteKlein As Variant

Erase mabytASCII_Encrypt

' Ziffern 0-9 (ASCII: 48 To 57)

lngAnzahl = 10
bytStartASCII_1 = 48

ReDim abytTemp_1(0 To lngAnzahl - 1)
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
abytTemp_1(lngI) = lngI + bytStartASCII_1
Next

If blnTextZiffernUmwandeln Then
Randomize Timer
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
lngR = Int(lngAnzahl * Rnd)
bytTemp = abytTemp_1(lngI)
abytTemp_1(lngI) = abytTemp_1(lngR)
abytTemp_1(lngR) = bytTemp
Next
End If

For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
mabytASCII_Encrypt(lngI + bytStartASCII_1) = abytTemp_1(lngI)
Next

' Buchstaben A-Za-z (ASCII: 65 To 90, 97 To 122)

lngAnzahl = 26
bytStartASCII_1 = 65
bytStartASCII_2 = 97

ReDim abytTemp_1(0 To lngAnzahl - 1)
ReDim abytTemp_2(0 To lngAnzahl - 1)
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
abytTemp_1(lngI) = lngI + bytStartASCII_1
abytTemp_2(lngI) = lngI + bytStartASCII_2
Next

Randomize Timer
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
lngR = Int(lngAnzahl * Rnd)

bytTemp = abytTemp_1(lngI)
abytTemp_1(lngI) = abytTemp_1(lngR)
abytTemp_1(lngR) = bytTemp

bytTemp = abytTemp_2(lngI)
abytTemp_2(lngI) = abytTemp_2(lngR)
abytTemp_2(lngR) = bytTemp

Next

For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
mabytASCII_Encrypt(lngI + bytStartASCII_1) = abytTemp_1(lngI)
mabytASCII_Encrypt(lngI + bytStartASCII_2) = abytTemp_2(lngI)
Next

' Buchstaben-Umlaute Ä,Ö,Ü;ä,ö,ü (ASCII: 196, 214, 220; 228, 246, 252)

avarUmlauteGross = Array(196, 214, 220)
avarUmlauteKlein = Array(228, 246, 252)

lngAnzahl = UBound(avarUmlauteGross) + 1

ReDim abytTemp_1(0 To lngAnzahl - 1)
ReDim abytTemp_2(0 To lngAnzahl - 1)
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
abytTemp_1(lngI) = avarUmlauteGross(lngI)
abytTemp_2(lngI) = avarUmlauteKlein(lngI)
Next

Randomize Timer
For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
lngR = Int(lngAnzahl * Rnd)

bytTemp = abytTemp_1(lngI)
abytTemp_1(lngI) = abytTemp_1(lngR)
abytTemp_1(lngR) = bytTemp

bytTemp = abytTemp_2(lngI)
abytTemp_2(lngI) = abytTemp_2(lngR)
abytTemp_2(lngR) = bytTemp

Next

For lngI = LBound(abytTemp_1) To UBound(abytTemp_1)
mabytASCII_Encrypt(avarUmlauteGross(lngI)) = abytTemp_1(lngI)
mabytASCII_Encrypt(avarUmlauteKlein(lngI)) = abytTemp_2(lngI)
Next

End Sub

Private Function getAnonymValue(ByVal varWert As Variant, blnTextZiffernUmwandeln) As Variant
If Len(varWert) > 1 Then
If IsDate(varWert) Then
If varWert < 1 Then
varWert = Rnd
Else
varWert = varWert + Int(Rnd * 365 + 1)
End If
ElseIf IsNumeric(varWert) And TypeName(varWert) "String" Then
varWert = getAnonymNumber(varWert)
ElseIf TypeName(varWert) = "String" And blnTextZiffernUmwandeln = True Then
varWert = getAnonymText(varWert)
End If
End If
getAnonymValue = varWert

End Function

Private Function getAnonymText(ByVal strText As String) As String

Dim abytASCII() As Byte
Dim lngA As Long
Dim bytASCII As Byte

Dim lngLBound As Long
Dim lngUBound As Long

lngLBound = LBound(mabytASCII_Encrypt)
lngUBound = UBound(mabytASCII_Encrypt)

abytASCII = StrConv(strText, vbFromUnicode)

For lngA = 0 To UBound(abytASCII)

If abytASCII(lngA) >= lngLBound Then
If abytASCII(lngA) 0 Then abytASCII(lngA) = bytASCII

End If
End If

Next

getAnonymText = StrConv(abytASCII, vbUnicode)

End Function

Private Function getAnonymNumber(ByVal varWert As Variant) As Variant

Dim lngVarType As VbVarType
Dim strWert As String
Dim dblWert As Double
Dim sngVorkomma As Single
Dim sngNachkomma As Single
Dim lngNachkommaStellen As Long
Dim lngVorkommaStellen As Long

Dim blnPunkt As Boolean

' Ganzzahlige Zufallszahlen innerhalb eines bestimmten Bereichs:
' Int((Obergrenze - Untergrenze + 1) * Rnd + Untergrenze)

lngVarType = VarType(varWert)

If lngVarType = vbDouble Then

dblWert = CDbl(varWert)

ElseIf lngVarType = vbString Then

strWert = CStr(varWert)

If InStr(strWert, ".") > 0 Then
blnPunkt = True
dblWert = CDbl(Val(strWert))
Else
dblWert = CDbl(strWert)
End If
End If

sngVorkomma = Int(dblWert)
sngNachkomma = dblWert - sngVorkomma

If sngNachkomma > 0 Then

lngNachkommaStellen = Len(CStr(sngNachkomma)) - 2
sngNachkomma = Int((10 ^ lngNachkommaStellen - 10 ^ (lngNachkommaStellen - 1) + 1) * _
Rnd + 10 ^ (lngNachkommaStellen - 1)) / (10 ^ lngNachkommaStellen)
End If

lngVorkommaStellen = Len(CStr(sngVorkomma))
sngVorkomma = Int((10 ^ lngVorkommaStellen - 10 ^ (lngVorkommaStellen - 1) + 1) * _
Rnd + 10 ^ (lngVorkommaStellen - 1))

If lngVarType = vbDouble Then

getAnonymNumber = CSng(sngVorkomma + sngNachkomma)

ElseIf lngVarType = vbString Then

If blnPunkt Then
getAnonymNumber = Replace(CStr(sngVorkomma + sngNachkomma), ",", ".")
Else
getAnonymNumber = CStr(sngVorkomma + sngNachkomma)
End If

End If

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

die Eigenschaften werden entfernt, Kopf/Fußzeilen und als Text hinterlegte Zahlen werden nicht ersetzt. (wenn im zweiten Dialog nein gewählt wird)

haklesoft · 10. Juni 2015

Hallo Chris,

als Text hinterlegte Zahlen werden nicht ersetzt. (wenn im zweiten Dialog nein gewählt wird)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ja, mit einer kleinen Ausnahme: wenn in einem als Text formatierten Feld der Eintrag wie ein Datum ( z. B. 01.04.2015) ausschaut, dann wird die erste führende Null unterdrückt, beide Punkte fliegen raus, der Monat bleibt erhalten, das Jahr wird umgesetzt. Ergebnis: 1042254

Sagst Du auch noch was zu Ralfs Gegenargumenten in #21

RPP63 · 10. Juni 2015

Danke, haklesoft! *tongue.gif*
Denn: Zwischenzeitlich fühlte ich mich wie der Einäugige unter den (nicht Blinden, sondern) Vernebelten.
Alles toll, obfuskieren gibt es schon, aber "Schuster, bleib bei den Füße-Habenden"!

Gruß Ralf

chris-kaiser · 10. Juni 2015

Hallo,

ob das jemand verwenden will, bleibt ja jedem selber überlassen!
*wink.gif*
Wird der Code verwendet kann der Fragesteller immer noch entscheiden ob die Datei angehängt werden sollte und es Ihm/Ihr anonym genug ist.

Bei so einem einfachen Tabellenaufbau wie Ralf es darstellt würden nicht mal Formeln benötigt werden und sind auch verbundene Zellen enthalten könnte es schon Probleme geben.
Enthalten die Daten jetzt doppelte Einträge (Namen,Artikel,usw...) wäre Name1, Name2, Name 3 oder Artikel 1, Artikel 2 auch nicht mehr zielführend wenn die Fragestellung lauten würde. "Fasse alle gleichen Daten......"
Das hat xlph ja gut im Code umgesetzt das gleiche Einträge erhalten bleiben.

Ich habe mir nur mal schnell über Google ein paar Ausschnitte angeschaut, was so an Tabellenaufbau vorhanden ist...
https://www.google.at/search?biw=150...61.iazwfXC-QGk

Ich vermute mal mehr als die Hälfte der Abbildungen haben keinen sinnvollen einfachen Tabellenaufbau....
p.s
Das mit Text formatierten Datum hatte ich nicht getestet, werde ich mir in nächster Zeit einmal anschauen.

chris-kaiser · 10. Juni 2015

Hallo,

anbei als Add-in (lauffähig ab Excel 2010)
Datei entzippen -> Speicherort festlegen
In Excel -> Datei -> Optionen -> Add-ins -> gehe zu -> durchsuchen -> und Datei auswählen -> Ok.

Deaktivierung des Add-ins -> gleicher Weg nur wird keine Datei mehr gewählt sondern nur mehr der Haken bei Beispielmappe erzeugen deaktivieren.

Gestartet wird es über ein Icon im Register Start (ganz rechts, Bsp.Mappe erzeugen)

und @Ralf du kommst dort auch vor.
ggf. möchte es ja war testen, danke!
Code ist frei einsehbar (ohne Schutz)

F-Projekt · 6. August 2016

Hallo,

wenn ich die Datei runterlade und in Excel öffne, werde ich gefragt, ob ich Makros zulassen möchte. Das habe ich bestätigt. Dann kommt folgende Meldung:

2016-08-06_16h03_38.png

Wenn ich dann auf Ja gehe, kommt das Fenster:

2016-08-06_16h05_15._sicherheitshinweispng.png

Wenn ich auf Makros aktivieren gehe nochmal.

2016-08-06_16h06_51_Bild3.png

Die dort angegeben Datei existiert nicht. Vermutlich, weil ich die Datei in einer Sandbox geöffnet habe, wie man es ja machen soll mit runtergeladen Dateien.

Dennoch gibt es dann eine Menüpunkt unter START.

Lässt sich dann aber nicht ausführen.

2016-08-06_16h11_05.png

Wenn ich den obrigen Code so ausführe in Excel, kommt nicht das Fenster aus dem Screenshot, aber 1-2 Abfragen und es wird nichts geändert.

Grüße

F-Projekt

Gonzi · 22. September 2023

Danke für die Codes, das ist echt toll wie ihr das macht.
Frage: Gibt es eine möglichkeit, Daten zu pseudonymisieren? Sprich man soll es wieder depseudonymisieren können?

Beispiel:
123 -> abe
483 -> 9iu
123 -> abe (es soll die gleiche pseudonymisierung aufweisen wie das erste beispiel)

Dazu wäre es toll, wenn man die länge der pseudonymisierung auswählen kann, z.B. 24 Zeichen, kleine buchstaben und zahlen.