Office: Anonymisierung und Pseudonymisierung von Beispielmappen

chris-kaiser · 26. Mai 2015

Hallo,
eine Beispielmappe die dem Originalaufbau entspricht ist für Helfer immer wünschenswert!
Aber verständlicher Weise aus Datenschutzgründen nicht immer machbar!
Keine Ahnung wie oft ich schon geschrieben habe „bitte eine Demomappe hochladen“ und als Antwort bekommen habe. „Darf/kann/möchte ich nicht da es personen/firmenbezogene Daten enthält. Eine Demomappe braucht keine „ECHTEN“ Daten, diese sollten durch irgendwas ersetzt werden, wichtig ist den Aufbau der Tabelle/Mappe zu kennen.

Um das zu erreichen ohne viel Aufwand gehe wie folgt vor:

Mache eine Kopie der Mappe (speichern unter)

Drücke Alt+F11

Menü -> einfügen Modul

Kopiere den VBA Code in dieses Modul

Schließe das VBA Fenster

Markiere deine Bereiche/Spalte/Zeilen oder das gesamte Blatt.

Drücke Alt+F8 und führe das Makro aus.

ggf. für weitere Tabellenblätter oder Bereiche den Vorgang wiederholen

.

Und fertig ist die Demomappe.

Option Explicit
Sub anonymisieren()
Randomize
Dim rng_s As Range
Dim rng_cell As Range
Dim check As Integer
Dim i As Integer
Dim VK, VE
With Application
VK = .Calculation
VE = .EnableEvents
End With
If TypeOf Selection Is Range Then
check = IIf(MsgBox("Sollen auch Datumswerte und Zahlen ersetzt werden?", vbYesNo, "Was soll alles ersetzt werden") = vbYes, 3, 2)
On Error Resume Next
Set rng_s = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, check)
If rng_s.Count > Selection.Count Then Set rng_s = Selection
If Err.Number = 0 Then
On Error GoTo 0
Call speedup(-4135, False, False)
On Error GoTo errMsg
For Each rng_cell In rng_s
With rng_cell
If IsDate(.Value) Then
If .Value < 1 Then
.Value = Rnd()
Else
.Value = .Value + Int(Rnd() * 365 + 1)
End If
ElseIf IsNumeric(.Value) Then
.Value = f_num(.Value)
Else
.Value = f_txt(.Value)
End If
End With
Next
Else
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation
End If
Else
MsgBox "Sie sollten zumindest eine Zelle markieren!", vbInformation
End If
Call speedup(VK, True, True)
Exit Sub
errMsg:
Call speedup(VK, True, True)
MsgBox Err.Number & " " & Err.Description
End Sub

Sub speedup(ByVal CalC As Integer, ByVal BolE As Boolean, BolScreenU As Boolean)
With Application
.Calculation = CalC
.EnableEvents = BolE
.ScreenUpdating = BolScreenU
End With
End Sub

Function f_txt(str_txt As String) As String
Dim i As Integer
For i = 1 To Len(str_txt)
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 65, 97) + Int(Rnd() * 25 + 1))
Next
f_txt = str_txt
End Function

Function f_num(dbl_val As Variant) As Double
Dim i As Integer
For i = 1 To Len(dbl_val)
If IsNumeric(Mid(dbl_val, i, 1)) Then
Mid(dbl_val, i, 1) = Int(Rnd() * 10)
End If
Next
f_num = CDbl(dbl_val)
End Function

Lukas Mosimann. Projektbetreuung durch mumpel

Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Falls ich etwas vergessen habe oder jemand noch Verbesserungsideen hat nur her damit. *Smilie

lg
Chris

:)

Hajo_Zi · 28. Mai 2015

Hallo Chris,

ich habe den Code nicht getestet, da wenig Zeit. Aber ich habe den Beitrag in meiner Hilfe Datei verlinkt.
Vielleich ergänze ich ihn auch in meinem Textbaustein, falls Du nichts dagegen hast?

Superingo2 · 28. Mai 2015

Hallo Chris,

geniale Idee, und ziemlich sicher auch ein geniales Programm.
Leider kann ich den Code nicht in mein Modul kopieren: Alle Zeilenumbrüche werden dabei nicht erkannt.
Mache ich etwas falsch?
Kannst Du den Code nicht mithilfe des hiesigen PHP-Buttons einfügen?

LG Ingo

Hajo_Zi · 28. Mai 2015

Hallo Ingo,

erst nach Word und dann VBA Editor.

GMG-CC · 28. Mai 2015

Einfach nur super, Chris! Danke.

Falls andere User auch Probleme mit dem Zeilenumbruch haben: Ich habe die Datei als Textdatei im *.zip-Format erstellt und hier als Anhang beigefügt. Und als ganz kleine Referenz an den Autor ist die ZIP mit einem Passwort versehen. Es lautet:
Code:

Danke, Chris!
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

also mit einem Leerzeichen nach dem Komma und entsprechender Groß- Kleinschreibung.

In jedem Fall werde ich die Datei auch in meinem Blog anbieten, selbstredend mit Nennung des Autoren (ich heiße ja nicht Karl-Theodor zu Guttenberg *wink.gif*).

haklesoft · 28. Mai 2015

Hallo Chris,

dickes Lob, das hast Du prima gemacht. *10points

Zur Beruhigung der Anwender könnte man noch die Anonymisierung der Dokumenteneigenschaften (Firma, Autor, Manager, zuletzt gespeichert von) sowie der Kopf- und Fußzeilen einbauen.

xlph · 28. Mai 2015

Hallo Chris,

tolle Idee.

Ich habe mir erlaubt deinen Code aufzugreifen und ihn etwas zu optimieren.

Insbesondere das abklappern von Zelle zu Zelle über eine For Each - Schleife.

Wenn möglich werden die Teilbereiche in ein Array gelesen und dieses
wird nach dem anonymisieren wieder ins Blatt zurück geschrieben.

Sieht viel aus, aber dafür recht schnell.

Vielleicht lässt sich hier und da noch was optimieren.

Viel Spaß.

Code:

Option Explicit

Public Sub Anonymisieren_XLPH()

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 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

Const conArrayGroesse As Long = 10000

If Not TypeOf Selection Is Range Then
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
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation: Exit Sub
End If

For Each rngArea In rngBereich.Areas

Randomize Timer

With rngArea

lngAnzahlWerte = WorksheetFunction.CountA(.Cells)

If lngAnzahlWerte = 1 Then

.Value = getAnonymValue(.Value)

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))

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))

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

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))

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

Next

End If

End If
End With
Next

End Sub

Private Function getAnonymValue(ByVal varWert As Variant) As Variant

If IsDate(varWert) Then
If varWert < 1 Then
varWert = Rnd
Else
varWert = varWert + Int(Rnd * 365 + 1)
End If
ElseIf IsNumeric(varWert) Then
varWert = getAnonymNumber(varWert)
Else
varWert = getAnonymText(varWert)
End If

getAnonymValue = varWert

End Function

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

Private Function getAnonymText(ByVal strText As String) As String

Dim abytASCII() As Byte
Dim lngA As Long

abytASCII = StrConv(strText, vbFromUnicode)

For lngA = 0 To UBound(abytASCII)

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

If abytASCII(lngA)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ebs17 · 28. Mai 2015

Das ist ja ein hochproduktiver Tag der Excelexperten. Respekt.

chris-kaiser · 28. Mai 2015

Hallo,
eine Beispielmappe die dem Originalaufbau entspricht ist für Helfer immer wünschenswert!
Aber verständlicher Weise aus Datenschutzgründen nicht immer machbar!
Keine Ahnung wie oft ich schon geschrieben habe „bitte eine Demomappe hochladen“ und als Antwort bekommen habe. „Darf/kann/möchte ich nicht da es personen/firmenbezogene Daten enthält. Eine Demomappe braucht keine „ECHTEN“ Daten, diese sollten durch irgendwas ersetzt werden, wichtig ist den Aufbau der Tabelle/Mappe zu kennen.

Um das zu erreichen ohne viel Aufwand gehe wie folgt vor:

Mache eine Kopie der Mappe (speichern unter)

Drücke Alt+F11

Menü -> einfügen Modul

Kopiere den VBA Code in dieses Modul

Schließe das VBA Fenster

Markiere deine Bereiche/Spalte/Zeilen oder das gesamte Blatt.

Drücke Alt+F8 und führe das Makro aus.

ggf. für weitere Tabellenblätter oder Bereiche den Vorgang wiederholen

Code:

Option Explicit
Sub anonymisieren()
Randomize
Dim rng_s As Range
Dim rng_cell As Range
Dim check As Integer
Dim i As Integer
Dim VK, VE
With Application
VK = .Calculation
VE = .EnableEvents
End With
If TypeOf Selection Is Range Then
check = IIf(MsgBox("Sollen auch Datumswerte und Zahlen ersetzt werden?", vbYesNo, "Was soll alles ersezt werden") = vbYes, 3, 2)
On Error Resume Next
Set rng_s = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, check)
If rng_s.Count > Selection.Countlarge Then Set rng_s = Selection
If Err.Number = 0 Then
On Error GoTo 0
Call speedup(-4135, False, False)
On Error GoTo errMsg
For Each rng_cell In rng_s
With rng_cell
If IsDate(.Value) Then
If .Value < 1 Then
.Value = Rnd()
Else
.Value = .Value + Int(Rnd() * 365 + 1)
End If
ElseIf IsNumeric(.Value) Then
.Value = f_num(.Value)
Else
.Value = f_txt(.Value)
End If
End With
Next
Else
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation
End If
Else
MsgBox "Sie sollten zumindest eine Zelle markieren!", vbInformation
End If
Call speedup(VK, True, True)
Exit Sub
errMsg:
Call speedup(VK, True, True)
MsgBox Err.Number & " " & Err.Description
End Sub

Sub speedup(ByVal CalC As Integer, ByVal BolE As Boolean, BolScreenU As Boolean)
With Application
.Calculation = CalC
.EnableEvents = BolE
.ScreenUpdating = BolScreenU
End With
End Sub

Function f_txt(str_txt As String) As String
Dim i As Integer
For i = 1 To Len(str_txt)
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 65, 97) + Int(Rnd() * 25 + 1))
Next
f_txt = str_txt
End Function

Function f_num(dbl_val As Variant) As Double
Dim i As Integer
For i = 1 To Len(dbl_val)
If IsNumeric(Mid(dbl_val, i, 1)) Then
Mid(dbl_val, i, 1) = Int(Rnd() * 10)
End If
Next
f_num = CDbl(dbl_val)
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Noch einmal der gleiche Post..., das der Code im ersten nicht "kopierbar" war ist mir nicht aufgefallen.....
*rolleyes.gif*
Edit Count in Countlarge geändert!
lauffähig ab Version 2007
in den Versionen kleiner als 2007
Countlarge in Count ändern.

chris-kaiser · 28. Mai 2015

Guten Morgen,
Erstmal danke an Alle für das Feedback!

@Hajo,
Grundsätzlich hätte ich nichts dagegen, aber dann sollten deine Textbausteine auch ein wenig überarbeitet werden. Meiner Meinung nach überforderst Du damit Forenneulinge.
Wenn Du willst könnten wir das aber gerne über PN absprechen, im Forum selber möchte ich das jetzt nicht diskutieren.

@xlph
Schön gefällt mir *Smilie, aber du hast die Teufelsdinger (MergeCells) vergessen.
Da läuft der Code auf lfz 13. Den Geschwindigkeitsunterschied habe ich noch nicht getestet, aber da ist deine Arrayvariante sicherlich schneller. Wenn ich heute dazukomme werde ich mal testen.

lg Chris

hary · 28. Mai 2015

Moin Chris
Feine Sache!!
Da du Langeweile hast, baust du noch dein NamenAddin Code ein. ;-)))
Das nutze ich noch immer.
Edit: hier der link
http://www.ms-office-forum.net/forum....php?p=1313178
Denn aus Oskar,Wild wird VUCgVsXtCk
gruss hary

haklesoft · 28. Mai 2015

Hallo Chris,

die Umwandlung von Text ergibt m. E. zu kryptische Rückgaben. Die Struktur und die Art der Inhalte von Textfeldern lässt sich dann nicht mehr überschauen und die angeforderte Hilfe wird unnötig erschwert.

Wie auch schon von xlph gezeigt, sollten bei Textumwandlungen Groß- und Kleinbuchstaben auch wieder Groß- und Kleinbuchstaben ergeben und außerdem Sonderzeichen im Text ohne Umwandlung erhalten bleiben. Da auch die Blanks erhalten bleiben, sind so auch die Wortgrenzen vorhanden. Ich würde aber auch Zahlen im Text unverändert lassen.

Mein Vorschlag könnte in Deiner Funktion so umgesetzt werden: Code:

Function f_txt(ByVal str_txt As String) As String
Dim i As Integer
For i = 1 To Len(str_txt)
Select Case Asc(Mid(str_txt, i, 1))
Case 0 To 31 'Steuerzeichen beibehalten
Case 32 To 47, 58 To 64, 91 To 96, 123 To 126, 167, 180 'Satz- und Sonderzeichen beibehalten
Case 48 To 57 'Zahlen im Text beibehalten
Case 65 To 90, 196, 214, 220 'Großbuchstaben bleiben Großbuchstaben
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 64 + Int(Rnd() * 25 + 1), 91 - Int(Rnd() * 25 + 1))) '+ Int(Rnd() * 25 + 1))
Case 97 To 122, 223, 228, 246, 252 'Kleinbuchstaben bleiben Kleinbuchstaben
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 96 + Int(Rnd() * 25 + 1), 123 - Int(Rnd() * 25 + 1))) ' + Int(Rnd() * 25 + 1))
Case Else 'anderen Zeichen wie bisher umwandeln
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 65, 97) + Int(Rnd() * 25 + 1))
End Select
Next
f_txt = str_txt
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

chris-kaiser · 28. Mai 2015

Hallo haklesoft,

danke, werde ich einbauen.
Ich selber bin die nächsten Tage auf Urlaub *biggrin.gif*
Wenn alles getestet und verbessert worden ist werde ich noch einmal einen Thread aufmachen mit dem gleichen Thema damit die letzten gültigen Codes auch gleich gefunden werden können.
Das Countlarge liegt mir auch noch im Magen ^^, da werde ich eine bedingte Kompilierung einbauen oder noch eine zusätzliche Fehlerbehandlung damit es in allen gängigen Versionen funktioniert.

wünsche ein schönes WE.
Chris

xlph · 28. Mai 2015

Hallo Chris,

Verbundene Zellen sind für Arrays kein Problem.

Fehler behoben:

Code:

If lngAnzahlWerte = 1 Then
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ersetzt durch:

Code:

If .Rows.Count = 1 And .Columns.Count = 1 Then
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Verbundene Zellen stellen nun mal ein Array dar.

Was aber weiterhin das Problem ist, ist wenn einzelne verbundene
Zellen markiert werden. SpecialCells gibt dann alle Zellen des Blattes
mit Konstanten zurück. Das konnt ich bei nicht verbundener Zelle einfach
umschiffen indem ich die Letzte Zelle des Blattes mit in die SpeciaCells-
Prüfung nehme, bei einer verbundenen Zelle lässt sich das nicht umgehen.

Das kann man auch manuelle leicht nachprüfen:
Eine verbundene Zelle markieren (mit oder ohne Inhalt, in anderen Zellen
sollten Werte eingetragen sein), [F5] drücken, [Inhalte]->'Konstanten'->[OK].

Korrektur:

Code:

Public Sub Anonymisieren_XLPH()

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 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

Const conArrayGroesse As Long = 10000

If Not TypeOf Selection Is Range Then
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
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation: Exit Sub
End If

For Each rngArea In rngBereich.Areas

Randomize Timer

With rngArea

lngAnzahlWerte = WorksheetFunction.CountA(.Cells)

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

.Value = getAnonymValue(.Value)

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))

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))

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

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))

Next
Next

rngBlock.Value = avarData()

Set rngBlock = Nothing

Next

End If

End If
End With
Next

End Sub

Private Function getAnonymValue(ByVal varWert As Variant) As Variant

If IsDate(varWert) Then
If varWert < 1 Then
varWert = Rnd
Else
varWert = varWert + Int(Rnd * 365 + 1)
End If
ElseIf IsNumeric(varWert) Then
varWert = getAnonymNumber(varWert)
Else
varWert = getAnonymText(varWert)
End If

getAnonymValue = varWert

End Function

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

Private Function getAnonymText(ByVal strText As String) As String

Dim abytASCII() As Byte
Dim lngA As Long

abytASCII = StrConv(strText, vbFromUnicode)

For lngA = 0 To UBound(abytASCII)

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

If abytASCII(lngA)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

jack_D · 29. Mai 2015

Moin Moin zusammen.

Ich find die Geschichte auch ganz großartig die Chris da auf die Beine gestellt hat.

Ich persönlich fänd es nur nützlich, wenn die konsistenz der Daten erhalten bleibt. (Also gleiche Werte bleiben gleiche Werte) Bisher, wenn ich das richtig überblickt hab, werden alle Werte unterschiedlich.
Bspw.
A1 = 614 (ALT) wird zu (716)
A2 = 615 (ALT) wird zu (719)
A3 = 614 (ALT) wird zu (800)

Nun wäre es doch toll, wenn "614" immer zu "716" wird.

Daher hab ich mich mal an einer Erweiterung probiert. Die auch in meinem geschützten Umfeld läuft. (Bezieht sich allerdings auf die for Each Lösung und ist noch nicht auf die schnelle Array Lösung angepasst)

BEste GRüße

Code:

Option Explicit
Private ObjAdd As Object
Private lfdNr As Long

Sub anonymisieren_JACK()
Randomize
Dim rng_s As Range
Dim Rng_Cell As Range
Dim check As Integer
Dim i As Integer
Dim VK, VE
Dim Wert, PWert

Set ObjAdd = CreateObject("Scripting.dictionary")
lfdNr = 1

With Application
VK = .Calculation
VE = .EnableEvents
End With

If TypeOf Selection Is Range Then
check = IIf(MsgBox("Sollen auch Datumswerte und Zahlen ersetzt werden?", vbYesNo, "Was soll alles ersezt werden") = vbYes, 3, 2)
On Error Resume Next

Set rng_s = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, check)
If rng_s.Count > Selection.CountLarge Then Set rng_s = Selection
If Err.Number = 0 Then
On Error GoTo 0
Call speedup(-4135, False, False)
'On Error GoTo errMsg
For Each Rng_Cell In rng_s

If ObjAdd.exists(Rng_Cell.Address) Then
Else

With Rng_Cell
If IsDate(.Value) Then
If .Value < 1 Then

PWert = .Value
Wert = Rnd()
Call alleGleich(PWert, Wert, rng_s, Rng_Cell)

Else
PWert = .Value
Wert = .Value + Int(Rnd() * 365 + 1)
Call alleGleich(PWert, Wert, rng_s, Rng_Cell)

End If
ElseIf IsNumeric(.Value) Then
PWert = .Value
Wert = f_num(.Value)
Call alleGleich(PWert, Wert, rng_s, Rng_Cell)

Else
PWert = .Value
Wert = f_txt(.Value)
Call alleGleich(PWert, Wert, rng_s, Rng_Cell)

End If
End With
End If
Next
Else
MsgBox "Bitte markieren sie Zellen mit Inhalt!", vbInformation
End If
Else
MsgBox "Sie sollten zumindest eine Zelle markieren!", vbInformation
End If
Call speedup(VK, True, True)
Exit Sub
errMsg:
Call speedup(VK, True, True)
MsgBox Err.Number & " " & Err.Description
End Sub

Sub speedup(ByVal CalC As Integer, ByVal BolE As Boolean, BolScreenU As Boolean)
With Application
.Calculation = CalC
.EnableEvents = BolE
.ScreenUpdating = BolScreenU
End With
End Sub

Function f_txt(str_txt As String) As String
Dim i As Integer
For i = 1 To Len(str_txt)
Mid(str_txt, i, 1) = Chr(IIf(Rnd() > 0.5, 65, 97) + Int(Rnd() * 25 + 1))
Next
f_txt = str_txt
End Function

Function f_num(dbl_val As Variant) As Double
Dim i As Integer
For i = 1 To Len(dbl_val)
If IsNumeric(Mid(dbl_val, i, 1)) Then
Mid(dbl_val, i, 1) = Int(Rnd() * 10)
End If
Next
f_num = CDbl(dbl_val)
End Function

Sub alleGleich(ByVal PWert As String, ByVal Wert As String, ByVal rng_s As Range, ByVal Rng_Cell As Range)
Dim LO, RU, ZO, ZU, SR, SL, ZS, ZZ
Dim rng_tmp, Rng_CellNeu

rng_tmp = rng_s.Address(False, False)

LO = Left(rng_tmp, InStr(rng_tmp, ":") - 1) 'links oben
RU = Right(rng_tmp, Len(rng_tmp) - InStr(rng_tmp, ":")) 'rechts unten

ZO = Range(LO).Row 'Zeile oben
ZU = Range(RU).Row 'Zeile unten

SR = Range(RU).Column 'Spalte Rechts
SL = Range(LO).Column

ZS = Rng_Cell.Column 'aktive Zell-Spalte
ZZ = Rng_Cell.Row 'aktive Zell-Zeile

For Each Rng_CellNeu In rng_s
'Positionsbestimmung
Select Case Rng_CellNeu.Row
Case Is < ZZ 'Eher

Case Is = ZZ 'gleiche Zeile
If Rng_CellNeu.Column >= ZS Then
If Rng_CellNeu.Value = PWert Then
Rng_CellNeu.Value = Wert
If Not ObjAdd.exists(Rng_CellNeu.Address) Then
ObjAdd.Add Rng_CellNeu.Address, lfdNr
lfdNr = lfdNr + 1
End If

End If
End If
Case Is > ZZ 'Später
If Rng_CellNeu.Value = PWert Then
Rng_CellNeu.Value = Wert
If Not ObjAdd.exists(Rng_CellNeu.Address) Then
ObjAdd.Add Rng_CellNeu.Address, lfdNr
lfdNr = lfdNr + 1
End If
End If
End Select

Next Rng_CellNeu

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