Obfuscate values in a spreadsheet

[monikersupreme]

I have a set of Excel spreadsheets that I am using as source data for a program I am writing. I want to create a set of data that retains the structure of the source data but obfuscates the cell values. In short, I need to keep the column names but should randomize numerical values, name strings, and dates.

Does anyone know of a VBA script that might do some or all of this already?

I was set to starting trying to write this from scratch but I feel (hope) perhaps some of the work may already be done...

Any advice would be much appreciated.

Thanks!

 

[actjfc]

This site https://www.excel-pratique.com/en/vba_tricks/vba-obfuscator.php does obfuscate the VBA code, not the values in the sheet. I tested, and it works well on the VBA side. However, for highly confidential code, I would not use it. I do not know who keeps the code once the obfuscation is done there.

I hope it helps later seekers of information.

 

[Rick Rothstein]

For anyone scouting this forum in the future, I did manage to find a plugin (prior to coming here) called AnonymousXL but I think it's for purchase only. There is a paper, however, that details the algorithm along with certain case considerations:

http://ceur-ws.org/Vol-1209/paper_15.pdf

You may be able to make use of the Obfuscate macro below (if you are not in a hurry that is as I expect this code to be sloooow if you have lots of sheets and data). The following code replaces every letter (preserving existing letter casing though) in every cell containing a text constant with a random letter. Numerical values (includes dates) are retained as is so that any formulas, math or date calculations remain unaffected. In effect, you will have the identical workbook with all cells containing text constants as gibberish.

[table="width: 500"]
[tr]
	[td]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[/td]
[/tr]
[/table]

 

[actjfc]

For small workbooks with some VBA code, if we apply both types of obfuscation then almost nobody will invest time trying to understand or hack the file to "steal" the proprietary ideas on it. It is a workaround for the known security flaws in the Excel passwords. Thanks for sharing!

 

[snb_]

In this approach:
- the columnheaders will not be affected
- identical string will get identical obfuscation 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