Daten anonymisieren

[schauan]

[Daten anonymisieren Teil 1]

Hallöchen zusammen,

zur besseren Veranschaulichung von Problemen und gewünschten Lösungen ist oftmals eine Bereitstellung von Daten hilfreich oder erforderlich. Die Helfer können so, ohne die Dateien nachzubauen, mit der Lösungsfindung beginnen, eventuelle Lösungsansätze mit den bereitgestellten Daten testen und den gewünschten Lösungen vergleichen.

Der Datenschutz gebietet, dass das natürlich nicht mit Originaldaten, insbesondere Firmen - und Mitarbeiterdaten, geschieht. Bereitgestellte Dateien sollten daher immer entsprechend anonymisierte Daten enthalten. Daten werden dabei willkürlich ersetzt, sodass im Gegensatz zu einer Verschlüsselung eine Entschlüsselung nicht möglich sein sollte.

Die Ersetzung sollte natürlich so erfolgen, dass keine Rückschlüsse auf die Originaldaten möglich sind. Einfach nur Buchstaben durcheinander zu bringen reicht da z.B. nicht. hzine lässt sicher den Namen Heinz vermuten ...

Die Anonymisierung kann man manuell durchführen oder auch makrogestützt. Hier in diesem ersten Teil stelle ich kurz eine Formellösung anhand Vor- und Nachnamen in 5 Schritten vor.

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

Anton

Freitag

Anton

Name01

Freitag

NachName01

Name01

NachName01

2

Berta

Schön

Berta

Name02

Schön

NachName02

Name02

NachName02

3

Caesar

Glöckner

Caesar

Name03

Glöckner

NachName03

Name03

NachName03

4

Anton

Freitag

Dieter

Name04

Leden

NachName04

Name01

NachName01

5

Dieter

Leden

Heinrich

Name05

Booter

NachName05

Name04

NachName04

6

Heinrich

Booter

Name05

NachName05

7

Berta

Schön

Schritt 1

Schritt 1

Name02

NachName02

8

Schritt 2

Schritt 2

9

Schritt 3

Zelle	Formel
M1	=SVERWEIS(A1;G$1:H$5;2;FALSCH)
N1	=SVERWEIS(B1;J$1:K$5;2;FALSCH)

Verwendete Systemkomponenten: [Windows (64-bit) NT 10.00] / MS Excel 365

Diese Tabelle wurde mit Tab2Html (v2.7.2) erstellt. ©Gerd alias Bamberg

Schritt 1
Eindeutige Listen der Vornamen und Nachnamen erzeugen (hier Spalten G und J)
Schritt 2
Neben Vornamen und Nachnamen Name01 bzw. Nachname01 usw. eintragen (hier Spalten H und K)
Schritt 3
Mit SVERWEIS ein Abbild der Originalliste mit den Ersatznaman und -vornamen erzeugen (hier Spalten M und N)
Schritt 4
Originale ersetzen. Dazu die erzeugten Daten kopieren und mit Inhalte einfügen - Werte einfügen (hier nicht dargestellt, da Spalten A und B damit überschrieben werden)
Schritt 5
Hilfsdaten löschen (hier Spalten M und N)

[schauan]

[Daten anonymisieren Teil 2]

Hier nun eine Makro - Lösung, bereitgestellt von Andreas Killer und von mir leicht bearbeitet.

Gleich zuerst zwei wichtige Hinweise.

• Die Lösung bitte auf einer Kopie Eurer Daten anwenden. Ansonsten sind schlimmstenfalls Eure Daten weg.
  
• Auch wenn bei Euch eventuelle keine Dateien mit Makros erlaubt sind, kann es je nach Restriktionen möglich sein, Makros in xlsx - Dateien auszuführen. Ihr könnt die Dateien in dem Fall nicht als xlsm speichern.
  

Das Makro ersetzt in einem auszuwählenden Bereich (Selection) Texte (Buchstaben), Zahlen (Ziffern), Zeiten und Daten durch jeweils zufällig erzeugte Daten. Enthaltene Formeln werden dabei übersprungen. Sollten auch die Ergebnisse von Formeln gewandelt werden, ist eine Codezeile auszukommentieren - siehe Kommentar im Code.

Um das Makro zu nutzen, könnt Ihr mit der Tastenkombination ALT+F11 in den VBA - Editor wechseln. Oben in der Menüleiste findet Ihr Einfügen und als Unterpunkt Modul. Im eingefügten Modul tut ihr dann den Code einfügen. Nun könnt Ihr z.B. wieder auf das Blatt wechseln und den zu anonymisierenden Bereich wählen. Anschließend wechselt Ihr wieder in den VBA-Editor, platziert den Cursor irgendwo zwischen Sub und End Sub, und startetdas Makro mit F5 oder über das Menü Ausführen, Unterpunkt Sub / Userform ausführen.

Hier nun der Code:


Modul Modul1

Option Explicit 
 
Sub Anonymize() 
  'Anonymize the data in the selected cells 
  '- replace letters with random choosed letters 
  '- replace digits in numbers, dates and times too 
  'Declaration Variables 
  Dim rngCelInSel As Range, rngInSel As Range 
  Dim strCelTxt As String, strDigit As String, strKey As String 
  Dim lCnt As Long 
  Static Dict As Object 'for Scripting.Dictionary 
  Dim vTemp 'for replace datas 
  'If there is other selection than range, then inform user and exit 
  If Not TypeOf Selection Is Range Then 
    MsgBox "Select some cells to anonymize and try again", vbInformation 
    Exit Sub 
  End If 
  'instantiate range variable for data range. If selection is greater 
  'then used range, it will be reduced 
  Set rngInSel = Intersect(ActiveSheet.UsedRange, Selection) 
  'if there is only not used range selected, then inform user and exit 
  If rngInSel Is Nothing Then 
    MsgBox "No data inside the select cells", vbInformation 
    Exit Sub 
  End If 
  'instantiate dictionary object and define vbTextCompare method 
  If Dict Is Nothing Then 
    Set Dict = CreateObject("Scripting.Dictionary") 
    Dict.CompareMode = vbTextCompare 
  End If 
  'loop through every cell 
  For Each rngCelInSel In rngInSel 
    With rngCelInSel 
      'skip empty cells or cells with formulas 
      'if you want to replace formula solutions, than comment out next code line 
      If .HasFormula Then GoTo Skip 
      If IsEmpty(rngCelInSel) Then GoTo Skip 
      'keep cell value into variable 
      strCelTxt = .Value 
      If Not Dict.Exists(strCelTxt) Then 
        strKey = strCelTxt 
        'replace dates 
        If IsDate(strCelTxt) Then 
          vTemp = .Value2 
          If VarType(vTemp) = vbString Then vTemp = CDate(vTemp) 
          If vTemp < 1 Then 
            .Value = Rnd 
          ElseIf Int(vTemp) = vTemp Then 
            .Value = Round(vTemp + 365 * (Rnd - 0.5), 0) 
          Else 
            .Value = vTemp + 365 * (Rnd - 0.5) 
          End If 
        'replace numbers 
        ElseIf IsNumeric(strCelTxt) Then 
          'loop through all digits in numbers 
          For lCnt = 1 To Len(strCelTxt) 
            strDigit = Mid$(strCelTxt, lCnt, 1) 
            If strDigit Like "#" Then Mid$(strCelTxt, lCnt, 1) = Chr(48 + Rnd * 9) 
          Next 
          .Value = CDbl(strCelTxt) 
        'replace all letters in text 
        Else 
          'loop through all letters in text 
          For lCnt = 1 To Len(strCelTxt) 
            Mid$(strCelTxt, lCnt, 1) = Chr(IIf(Rnd > 0.5, 65, 97) + Rnd * 26) 
          Next 
          .Value = strCelTxt 
        End If 
        Dict.Add strKey, rngCelInSel.Value 
      Else 
        .Value = Dict.Item(strCelTxt) 
      End If 
Skip: 
    End With 
  Next 
  'Remove all data from the Data Model if any 
  On Error Resume Next 
  VBA.CallByName ActiveWorkbook, "RemoveDocumentInformation", VbMethod, 23 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2019 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 20.0.0