Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1616to1620
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Klexys Musterdatei-Anonymisator

Klexys Musterdatei-Anonymisator
29.03.2018 19:15:00
Klexy
Frohe Osterhasen zusammen!
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

18
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Danke
29.03.2018 20:29:00
Fennek
Hallo,
vielen Dank für die Arbeit, es macht es für die Fragesteller hoffentlich einfachen. Ein "falsche" Verkürzung der Dateien ist vermutlich eins der größten Probleme der Foren.
Vor einiger Zeit habe ich einen vergleichbare Ansatz von Rick Rothstein gefunden:

https://www.mrexcel.com/forum/excel-questions/942338-obfuscate-values-spreadsheet-2.html
Sub Obfuscate()
Dim X As Long, WS As Worksheet, Cell As Range
Dim Txt As String, UpperLetters As String, LowerLetters As String
Randomize
UpperLetters = Join(RandomizeArray(Split(StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZ", vbUnicode),  _
Chr(0))), "")
LowerLetters = Join(RandomizeArray(Split(StrConv("abcdefghijklmnopqrstuvwxyz", vbUnicode),  _
Chr(0))), "")
Application.ScreenUpdating = False
For Each WS In ThisWorkbook
For Each Cell In Cells.SpecialCells(xlConstants, xlTextValues)
Txt = Cell.Value
For X = 1 To Len(Txt)
If Mid(Txt, X, 1) Like "[A-Z]" Then
Mid(Txt, X) = Mid(UpperLetters, Asc(Mid(Txt, X, 1)) - 64, 1)
ElseIf Mid(Txt, X, 1) Like "[a-z]" Then
Mid(Txt, X) = Mid(LowerLetters, Asc(Mid(Txt, X, 1)) - 95, 1)
End If
Next
Cell.Value = Txt
Next
Next
Application.ScreenUpdating = True
End Sub
Function RandomizeArray(ArrayIn As Variant) As String()
Dim Cnt As Long, RandomIndex As Long, Tmp As String
Randomize
For Cnt = UBound(ArrayIn) To LBound(ArrayIn) Step -1
RandomIndex = Int((Cnt - LBound(ArrayIn) + 1) * Rnd + LBound(ArrayIn))
Tmp = ArrayIn(RandomIndex)
ArrayIn(RandomIndex) = ArrayIn(Cnt)
ArrayIn(Cnt) = Tmp
Next
RandomizeArray = ArrayIn
End Function

Wie wäre es mit einem kleinen Test? Nutze deinen Code für ca 100 Zeilen und Interessierte kö _
nnen testen, ob er umkehrbar ist.
mfg

Anzeige
Umkehrbar ist das niemals, da Infoverlust
30.03.2018 19:03:45
lupo1
auf 2-3 und a-c und ein paar wenige Buchstaben mehr.
Damit ist es kein Obfuscator. Denn der behält den Grad der Information bei, da Code weiterhin funktioniert. Das tun Formeln hier auch, und die Anonymisierung betrifft nur die Daten.
AW: Umkehrbar ist das niemals, da Infoverlust
02.04.2018 01:04:11
Klexy
@ Lupo: Ich verstehe nicht, was du meinst und wen du meinst.
AW: Danke
02.04.2018 01:02:16
Klexy
Danke für den Vorschlag, Fennek.
Aber das Makro taugt nix. Es funktioniert nicht bei nur einem Tabellenblatt, nicht bei Zellen, die mit einem Rechenzeichen anfangen (auch wenn es keine Formeln sind), und nicht nur in den markierten Zellen, sondern in allen Zellen, auch in den Spaltenköpfen.
Anzeige
AW: Klexys Musterdatei-Anonymisator
29.03.2018 23:14:05
snb
Warum verwendest du kein VBA ?
Sub M_snb()
For j = 4 To 9
Selection.Replace j, 3 - j Mod 2
Next
End Sub

AW: Klexys Musterdatei-Anonymisator
02.04.2018 01:13:26
Klexy
Danke für den Tip, aber warum testest du es nicht, bevor du aufsprichst?
Deine Variante bringt einen Geschwindigkeitsvorteil von weniger als 0,2 Promille und ist schlechter lesbar und verständlich.
AW: Klexys Musterdatei-Anonymisator
30.03.2018 13:03:43
snb
Coulmnheaders werden nicht geändert.
Identische 'strings' bekommen identische Ersatz strings.
Sub M_snb()
Randomize
With CreateObject("scripting.dictionary")
For Each it In Sheets(1).UsedRange.Offset(1).SpecialCells(2, 2)
.Item(it) = Join(Array(Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int( _
26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd)), Chr(65 + Int(26 * Rnd))), "")
Next
For Each it In .keys
Sheets(1).UsedRange.Offset(1).Replace it, .Item(it), 1
Next
End With
End Sub

Anzeige
AW: für Fragesteller bereithalten
30.03.2018 17:28:41
Fennek
Hallo,
diese Ansätze sollte für Fragesteller - leicht zugänglich - bereitgestellt werden. Da dieses Forum -vermutlich- nicht moderiert wird, käme z.B. CEF infage.
mfg
(ich kann den link nicht auslesen)
Der permanente Link hierher ist
30.03.2018 19:23:01
lupo1
ergibt sich gemäß
https://www.herber.de/forum/archiv/1592to1596/t1592601.htm (Herber-Linksystematik)
nach temporärem (und direkt beantwortbarem, je ~6 Tage)
https://www.herber.de/forum/messages/1617385.html
zu endgültigem (Punkt 2c)
https://www.herber.de/forum/archiv/1616to1620/t1617313.htm Threadbeginn
https://www.herber.de/forum/archiv/1616to1620/t1617313.htm#1617385 snb
oder (Punkt 4) zu
https://www.herber.de/cgi-bin/callthread.pl?index=1617313
https://www.herber.de/cgi-bin/callthread.pl?index=1617313#1617385
Du hast aber recht, Fennek: Das manuelle Link-Erstellen dauert immer etwas!
Anzeige
Neue verbesserte Version
02.04.2018 02:19:05
Klexy
Wir brauchen tatsächlich einen permanenten Link, wenn das Makro dann gebrauchsfertig ist. Ich habe leider keinen Webspace, wo ich es hinterlegen könnte, sondern würde dann hier einen neuen Thread öffnen, den man dann direkt in den Startbeitrag verlinken kann. Den 15. Beitrag in einem Thread markieren geht zwar, ist aber umständlich und von manchen wahrscheinlich nicht nachvollziehbar und dann wissen sie nicht, welche der 10 Versionen im Thread die richtige ist, vor allem wenn danach noch kommentiert und rumgeflickt wird.
Hier ist jetzt die aktuelle Version, die ich nach den verlinkten Konkurrenzmakros und sonstigen gegoogelten Feinheiten verbessert habe.
Noch Vorschläge?

Sub Klexys_Musterdatei_Anonymisator()
AktivesMakro_o = AktivesMakro
AktivesMakro = "Klexys_Musterdatei_Anonymisator"
Dim Time1 As Double, Time2 As Double, Dauer As Double, Sonderzeichen As Variant
Dim Wo_Kopfzeile As Variant, Hier_Kopfzeile As Range, Spaltenkopf As Range, c As Long
Dim Kopfzeile As Integer, Kopfspalte As Integer, letzte_Zeile As Integer, s As Integer
Dim AnoBereich As Range, AnoKopf As Range, Teilbereich As Range, Kombination As Range
Dim AnzahlZellen As Integer, AnzahlZeilen As Integer, AnzahlSpalten As Integer
'________________________________________________________________________________________
' Hinweise:
'   Dieses Makro anonymisiert kritische Spalten in Dateien, die z.B. 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 Spalten/Zellen zu anonymisieren und nicht
'   die komplette Tabelle. Je mehr Daten anonymisiert werden, desto eher kann Datenmüll
'   in der Musterdatei entstehen, der dem Bearbeiter den Überblick unnötig erschwert.
'________________________________________________________________________________________
' Wirkungsweise:
'   Das Makro fragt zu Beginn ab, in welcher Zeile die Spaltenköpfe sind und anonymisiert
'   diese NICHT. Die Zeichen in den zu anonymisierenden Zellen 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.
'   Leerzeichen weredn nicht ersetzt, um die Wortstruktur zu erhalten.
'   Satzzeichen, Klammern und Rechenzeichen werden nicht ersetzt
'   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 SPALTEN markieren (sie müssen nicht zusammenhängend sein) und
'    Makro laufen lassen. Das Makro fragt die Kopfzeile ab, um diese von der Anonymisierung
'    auszuschließen (Zeilennummer eingeben).
'    Wenn nur ein beliebiger ZELLBEREICH, der keine Kopfzeile enthält, anonymisiert werden
'    soll, dann ein "x" eingeben.
'!!  Zellen mit FORMELN dürfen NICHT anonymisiert werden, sonst werden die Formeln zerstört
'    Das Makro schließt versehentlich markierte Formelzellen von der Anonymisierung aus.
'!!  Zellen mit eindeutigen SCHLÜSSELWERTEN oder LAUFENDEn NUMMERN (z.B. Kundennummern,
'    Matchcodes 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, was dem Bearbeiter den Überblick erschwert.
'!!  DATUMSSPALTEN sollten NICHT anonymisiert werden weil siehe oben.
'!!  Spaltenköpfe sollten im Sinne der Verständlichkeit NICHT anonymisiert werden.
'________________________________________________________________________________________
Vonvorne:
On Error Resume Next
Wo_Kopfzeile = InputBox(vbCr & vbCr & "In welcher Zeile sind die Spaltenköpfe?" & _
vbCr & "Bitte Zeilennummer eingeben." & vbCr & vbCr & _
"Wenn es ein Zellbereich ohne Spaltenköpfe ist, dann nur ein ""x"" eintragen." & _
vbCr & "", "Spaltenköpfe sollen im Klartext bleiben")
If IsNumeric(Wo_Kopfzeile) Then
If Wo_Kopfzeile * 1 = Int(Wo_Kopfzeile) Then
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
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
If Wo_Kopfzeile = "x" Then 'keine Kopfzeile im markierten Zellbereich
Set Kombination = Selection
GoTo Losgehts
Else
MsgBox vbCr & _
"Es muss etwas sinnvolles eingegeben werden!" & vbCr & _
"Los, nochmal!" & vbCr & _
vbCr & vbCr & _
"_____________________________________________________________________" & _
vbCr & "  Makro:  _" & AktivesMakro & "_ "
GoTo Vonvorne
End If
End If
Losgehts:
Time1 = Timer
If Kombination Is Nothing Then
Set Kombination = Selection
End If
AnzahlZellen = Kombination.Cells.Count
AnzahlZeilen = Kombination.Cells.Rows.Count
AnzahlSpalten = AnzahlZellen / AnzahlZeilen
'Formelzellen sicherheitshalber ausschließen:
Set Kombination = Kombination.SpecialCells(xlCellTypeConstants, 3)
Kombination.Select
AnzahlZellen = Kombination.Cells.Count
' =Zeichen (Muss gemacht werden, damit auch Zellen, die mit einem Rechenzeichen
' beginnen (aber keine Formeln sind) beim Anonymisieren mitgenommen werden.)
Selection.Replace What:="=", Replacement:="§$§$", LookAt:=xlPart, MatchCase:=True
' 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
' deutsche 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
Selection.Replace What:="ß", Replacement:="b", LookAt:=xlPart, MatchCase:=True
' deutsche 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
' Sonderzeichen
Sonderzeichen = MsgBox("Sollen auch türkische, slawische, griechische und " & _
"kyrillische Zeichen " & vbCr & "anonymisiert werden?" & vbCr, vbYesNo, "Warning")
Select Case Sonderzeichen
Case vbYes
Selection.Replace What:=ChrW(198), Replacement:="M", LookAt:=xlPart, MatchCase:=True
For c = 182 To 197
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
For c = 199 To 203
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
For c = 204 To 207
Selection.Replace What:=ChrW(c), Replacement:="I", LookAt:=xlPart, MatchCase:=True
Next
For c = 208 To 214
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
For c = 2016 To 221
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
For c = 222 To 229
Selection.Replace What:=ChrW(c), Replacement:="a", LookAt:=xlPart, MatchCase:=True
Next
Selection.Replace What:=ChrW(230), Replacement:="m", LookAt:=xlPart, MatchCase:=True
For c = 231 To 235
Selection.Replace What:=ChrW(c), Replacement:="a", LookAt:=xlPart, MatchCase:=True
Next
For c = 236 To 239
Selection.Replace What:=ChrW(c), Replacement:="i", LookAt:=xlPart, MatchCase:=True
Next
For c = 240 To 246
Selection.Replace What:=ChrW(c), Replacement:="a", LookAt:=xlPart, MatchCase:=True
Next
For c = 248 To 255
Selection.Replace What:=ChrW(c), Replacement:="a", LookAt:=xlPart, MatchCase:=True
Next
For c = 256 To 295
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
For c = 296 To 305
Selection.Replace What:=ChrW(c), Replacement:="I", LookAt:=xlPart, MatchCase:=True
Next
For c = 306 To 696
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
Case vbNo
End Select
Sonderzeichen = MsgBox("Sollen auch noch alle sonstige krummen Zeichen anonymisiert " & _
"werden?" & vbCr & "Das dauert dann noch 2 Minuten extra." & vbCr, vbYesNo, "Warning")
Select Case Sonderzeichen
Case vbYes
For c = 880 To 65536
Selection.Replace What:=ChrW(c), Replacement:="D", LookAt:=xlPart, MatchCase:=True
Next
Case vbNo
End Select
' =Zeichen rückgängig
Selection.Replace What:="§$§$", Replacement:="'=", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="'=", Replacement:="=", LookAt:=xlPart, MatchCase:=True
Time2 = Timer
Dauer = Time2 - Time1
MsgBox "Feddisch!" & vbCr & vbCr & "Es wurden " & _
Format(AnzahlZellen, "#,###") & " Zellen in " & _
Format(AnzahlZeilen, "#,###") & " Zeilen und " & _
Format(AnzahlSpalten, "#,###") & " Spalten anonymisiert." & _
vbCr & vbCr & "Dauer: " & Format(Dauer, "#,###.000") & " Sekunden"
AktivesMakro = AktivesMakro_o
End Sub

Anzeige
AW: Beispiel
02.04.2018 08:13:40
Gerd
Moin
' ' 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
Const Ziffern As String = "425362738293"
Dim L As Long
For L = 1 To 11 Step 2
Kombination.Replace What:=Mid(Ziffern, L, 1), Replacement:=Mid(Ziffern, L + 1, 1), LookAt:= _
xlPart, MatchCase:=True
Next

Gruß Gerd
Anzeige
AW: Beispiel
02.04.2018 17:09:16
Klexy
Danke Gerd, aber das ist (wie auch das von snb) keine Verbesserung, sondern nur eine Alternative.
Deine Version läuft 1% langsamer als meine.
Die Version von snb läuft 16% langsamer als meine (hatte ich gestern versehentlich falsch angegeben).
Testszenario: 40 Durchläufe á 30.000 Zellen mit den Zahlen von 1 - 30.000)
Hat noch jemand Verbesserungen oder Vorschläge für weitere Funktionalitäten oder Auswahlmöglichkeiten, die für eine Anonymisierung in Foren usw. relevant wären?
AW: Erweiterung
02.04.2018 17:18:48
Fennek
Hallo,
aufbauend auf dem Vorschlag von snb, eine Variante, die die Länge von Texten und die Groß-/Kleinschreibung erhält:
Sub F_en() 'bassierend auf snb's Vorschlag
'Randomize
Dim By() As Byte
With CreateObject("scripting.dictionary")
For Each it In Sheets(1).UsedRange.Offset(1).SpecialCells(2, 2)
By = it.Value
Tx = ""
For b = 0 To UBound(By) - 1 Step 2
If Sgn(((((By(b) - 1) Or 32) - 32) And 191) 
Es wurde nur mit sehr wenig Text getestet, also zur Laufzeit kann ich nicht sagen. Da i.d.R. 100 Datensätze reichen (und z.B. hier Dateien kleiner als 300kb sein müssen), dürfte es nicht so kritisch sein.
mfg
Anzeige
AW: Erweiterung
02.04.2018 18:22:09
Gerd
Hallo
Kombination.Select
Wenn du es mit den "Prozenten" hast, dann elemeniere dies zuerst.
Gruß Gerd
AW: ? owT
02.04.2018 22:23:36
Fennek
AW: Erweiterung
03.04.2018 00:13:31
Klexy
Da hast du Recht, aber es ist ja nicht meins, das langsamer ist.
Meins ist trotz diesem Select noch wesentlich schneller als die vorgeschlagenen Alternativen.
AW: Erweiterung
02.04.2018 23:31:52
Klexy
Hallo Fennek,
ich verstehe nicht, wo bei dieser Version der Vorteil liegen soll.
Testszenario: Tabelle mit 35 Spalten und 300 Zeilen, keine bedingten Formatierungen, 10 Spalten markiert.
Das Makro ändert willkürliche Zellen, nicht nur die markierten und auch nicht alle markierten.
Das Makro anonymisiert gleiche Wörter unterschiedlich und macht aus Ziffern Buchstaben.
Umlaute werden nicht geändert.
Außerdem ändert es bereits geänderte Zellen immer wieder (vermutlich mehrere hundert mal).
Dauer: 59 Sekunden
Der Vorteil zu snb (61 Sekunden) ist nur, dass die Anzahl der Zeichen in der Zelle nicht verändert wird.
Meine Version braucht 2 Sekunden und erfüllt alle oben kritisierten Bedingungen (die ich aufgrund meiner bisherigen Erfahrung für sinnvoll und gerechtfertigt halte)
Anzeige
AW: Klexys Musterdatei-Anonymisator
02.04.2018 01:24:22
Klexy
Warum testest du nicht?
Taugt nix.
Bearbeitet willkürlich irgendwelche Zellen und nicht die Markierung.
Ändert bereits geänderte Zellen immer wieder und bleibt in einer endlosen Schleife hängen.
Zellen enthalten nach der Bearbeitung mehr Zeichen als vorher.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige