MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 28.05.2015, 14:43   #1
chris-kaiser
MOF Guru
MOF Guru
Strahlen Hinweis - Anonymisierung und Pseudonymisierung von Beispielmappen

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:
  1. Mache eine Kopie der Mappe (speichern unter)
  2. Drücke Alt+F11
  3. Menü -> einfügen Modul
  4. Kopiere den VBA Code in dieses Modul
  5. Schließe das VBA Fenster
  6. Markiere deine Bereiche/Spalte/Zeilen oder das gesamte Blatt.
  7. Drücke Alt+F8 und führe das Makro aus.
  8. 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


VBA/HTML - CodeConverter für Office-Foren, AddIn für Excel/Word 2002-2013 - komplett in VBA geschrieben von Lukas Mosimann. Projektbetreuung durch mumpel

Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0


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

lg
Chris

__________________

Gruß Chris

Feedback nicht vergessen,
p.s Bitte keine PN (persönliche Nachrichten) mit Aufgabenstellungen schicken, Probleme sollten im Forum gelöst werden!
3a2920576572206973742064656e20646120736f206e65756769657269672e

Geändert von chris-kaiser (28.05.2015 um 14:45 Uhr).
chris-kaiser ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 14:48   #2
Hajo_Zi
MOF Guru
MOF Guru
Standard

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?

GrußformelHomepage

__________________

Signatur in jedem Beitrag
Im Forum kann der Beitrag als erledigt markiert werden. Also mache es unten links mit Klick auf den Schalter "als erledigt setzen", falls Problem gelöst.
Der Zustand des Beitrages wird dann in der Übersicht angezeigt und man braucht sich diese Beiträge nicht mehr ansehen.
Bitte Version angeben. Bei keiner Angabe gehe ich von meinen Angaben aus.
Betriebssystem: Windows 10 - 64 Bit, Office 2016 - 32 Bit.
Fragen werden im Forum beantwortet, nicht per PN.
Hajo_Zi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 16:51   #3
Superingo2
MOF Meister
MOF Meister
Standard

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

__________________

Viel Spaß


.....ein Feedback wäre nett.....
Superingo2 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 17:29   #4
Hajo_Zi
MOF Guru
MOF Guru
Standard

Hallo Ingo,

erst nach Word und dann VBA Editor.

Gruß Hajo

__________________

Signatur in jedem Beitrag
Im Forum kann der Beitrag als erledigt markiert werden. Also mache es unten links mit Klick auf den Schalter "als erledigt setzen", falls Problem gelöst.
Der Zustand des Beitrages wird dann in der Übersicht angezeigt und man braucht sich diese Beiträge nicht mehr ansehen.
Bitte Version angeben. Bei keiner Angabe gehe ich von meinen Angaben aus.
Betriebssystem: Windows 10 - 64 Bit, Office 2016 - 32 Bit.
Fragen werden im Forum beantwortet, nicht per PN.
Hajo_Zi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 18:11   #5
GMG-CC
MOF Koryphäe
MOF Koryphäe
Standard

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!
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 ).
Angehängte Dateien
Dateityp: zip ExcelDataAnonymisieren.zip (1,3 KB, 40x aufgerufen)

__________________

Gruß
Günther

Eine Rückmeldung ist gegenüber den Helfern einfach nur fair!

Mein Blog im Kindesalter: www.Excel-ist-sexy.de
Du kannst jeden Beitrag eines Helfers bewerten, schau mal die Symbole links unten an ...
GMG-CC ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 19:04   #6
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

Hallo Chris,

dickes Lob, das hast Du prima gemacht.

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.

__________________


Hang loose, haklesoft
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 21:35   #7
xlph
MOF Meister
MOF Meister
Standard

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) <= 47 Then
            ' Steuer-/Satz-Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 57 Then
            ' Ziffern 0-9
            abytASCII(lngA) = Int((57 - 48 + 1) * Rnd + 48)
        ElseIf abytASCII(lngA) <= 64 Then
            ' Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 90 Then
            ' Großbuchstaben
            abytASCII(lngA) = Int((90 - 65 + 1) * Rnd + 65)
        ElseIf abytASCII(lngA) <= 96 Then
            ' Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 122 Then
            ' Kleinbuchstaben
            abytASCII(lngA) = Int((122 - 97 + 1) * Rnd + 97)
        ElseIf abytASCII(lngA) <= 127 Then
            ' Zeichen unbehandelt lassen
        Else
            ' sonst Zufall zwischen 32 u. 127
            abytASCII(lngA) = Int((122 - 32 + 1) * Rnd + 32)
        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
xlph ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.05.2015, 21:50   #8
ebs17
MOF Guru
MOF Guru
Standard

Das ist ja ein hochproduktiver Tag der Excelexperten. Respekt.

__________________

Ein freundliches Glück Auf!

Eberhard

Abfrageperformance ist kein Geheimnis
SQL ist leicht: {0}:{1}:{2}:{3}:{4}:{5}:{6}:{7}:{8}:{9}:{10}:{11}:{12} <= geklammerte Zahlen sind Einzelthemen
Dein Dankeschön: DBWiki => Spende
ebs17 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 07:24   #9
chris-kaiser
Threadstarter Threadstarter
MOF Guru
MOF Guru
Strahlen Anonymisierung und Pseudonymisierung von Beispielmappen

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:
  1. Mache eine Kopie der Mappe (speichern unter)
  2. Drücke Alt+F11
  3. Menü -> einfügen Modul
  4. Kopiere den VBA Code in dieses Modul
  5. Schließe das VBA Fenster
  6. Markiere deine Bereiche/Spalte/Zeilen oder das gesamte Blatt.
  7. Drücke Alt+F8 und führe das Makro aus.
  8. 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
Noch einmal der gleiche Post..., das der Code im ersten nicht "kopierbar" war ist mir nicht aufgefallen.....

Edit Count in Countlarge geändert!
lauffähig ab Version 2007
in den Versionen kleiner als 2007
Countlarge in Count ändern.

__________________

Gruß Chris

Feedback nicht vergessen,
p.s Bitte keine PN (persönliche Nachrichten) mit Aufgabenstellungen schicken, Probleme sollten im Forum gelöst werden!
3a2920576572206973742064656e20646120736f206e65756769657269672e

Geändert von chris-kaiser (29.05.2015 um 07:42 Uhr).
chris-kaiser ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 07:25   #10
chris-kaiser
Threadstarter Threadstarter
MOF Guru
MOF Guru
Standard

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

__________________

Gruß Chris

Feedback nicht vergessen,
p.s Bitte keine PN (persönliche Nachrichten) mit Aufgabenstellungen schicken, Probleme sollten im Forum gelöst werden!
3a2920576572206973742064656e20646120736f206e65756769657269672e
chris-kaiser ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 08:10   #11
hary
MOF Guru
MOF Guru
Standard

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

Geändert von hary (29.05.2015 um 08:23 Uhr).
hary ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 10:09   #12
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

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

__________________


Hang loose, haklesoft
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 10:32   #13
chris-kaiser
Threadstarter Threadstarter
MOF Guru
MOF Guru
Standard

Hallo haklesoft,

danke, werde ich einbauen.
Ich selber bin die nächsten Tage auf Urlaub
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

__________________

Gruß Chris

Feedback nicht vergessen,
p.s Bitte keine PN (persönliche Nachrichten) mit Aufgabenstellungen schicken, Probleme sollten im Forum gelöst werden!
3a2920576572206973742064656e20646120736f206e65756769657269672e
chris-kaiser ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 11:48   #14
xlph
MOF Meister
MOF Meister
Standard

Hallo Chris,

Verbundene Zellen sind für Arrays kein Problem.

Fehler behoben:

Code:

If lngAnzahlWerte = 1 Then
ersetzt durch:

Code:

If .Rows.Count = 1 And .Columns.Count = 1 Then
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) <= 47 Then
            ' Steuer-/Satz-Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 57 Then
            ' Ziffern 0-9
            abytASCII(lngA) = Int((57 - 48 + 1) * Rnd + 48)
        ElseIf abytASCII(lngA) <= 64 Then
            ' Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 90 Then
            ' Großbuchstaben
            abytASCII(lngA) = Int((90 - 65 + 1) * Rnd + 65)
        ElseIf abytASCII(lngA) <= 96 Then
            ' Zeichen unbehandelt lassen
        ElseIf abytASCII(lngA) <= 122 Then
            ' Kleinbuchstaben
            abytASCII(lngA) = Int((122 - 97 + 1) * Rnd + 97)
        ElseIf abytASCII(lngA) <= 127 Then
            ' Zeichen unbehandelt lassen
        Else
            ' sonst Zufall zwischen 32 u. 127
            abytASCII(lngA) = Int((122 - 32 + 1) * Rnd + 32)
        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
xlph ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 29.05.2015, 12:34   #15
jack_D
MOF Koryphäe
MOF Koryphäe
Standard

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
jack_D ist gerade online  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 21:46 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.