Обезличивание выгрузки данных из Active Directory

В некоторых случаях в рамках взаимодействия с ГК «Иннотех» может возникнуть необходимость в выгрузке сведений из имеющейся у клиента базы данных Active Directory (AD) и передаче их специалистам службы поддержки, например, для целей тестирования.

Перед передачей выгруженные данные должны быть обезличены с помощью скрипта на Visual Basic в Microsoft Excel.

Скрипт обезличивает значения следующих атрибутов объектов AD: CN, DisplayName, GivenName, Name, SamAccountName, sn, Surname, Department, Description, City, Title, EmailAddress, mail, UserPrincipalName, CanonicalName, DistinguishedName, HomeDirectory и др.

Чтобы обезличить данные:

Выгрузите требуемый набор данных в файл в формате CSV с помощью стандартных средств Microsoft Active Directory Domain Services.
Создайте пустую книгу в Microsoft Excel.
На вкладке Данные нажмите Из текстового/CSV-файла.

Рис. 1. Вкладка «Данные» в Microsoft Excel
В диалоговом окне выберите CSV-файл с выгруженными данными и нажмите Импорт.
В окне предварительного просмотра убедитесь в корректности отображения данных. При необходимости внесите изменения в настройки отображения и нажмите Загрузить.

Рис. 2. Окно предварительного просмотра импортируемых данных
В качестве имени листа с импортированными данными укажите "deface".
Нажмите Alt+F11.
В окне Microsoft Visual Basic for Applications нажмите F7.

В области редактора кода вставьте текст скрипта:

Скрипт для обезличивания данных AD

Sub Main()

    ChangeValuesToGenerated
    ChangeValueToHeaderValue
    ReplaceEmails
    CanonicalNameProc
    legacyExchangeDNProc
    DistinguishedNameProc
    HomeDirectoryClean

End Sub

Sub ChangeValuesToGenerated()
    Dim ws As Worksheet
    Dim headerArray As Variant ' Create array of headers
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim j As Integer

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    headerArray = Array("CN", "DisplayName", "GivenName", "Name", "SamAccountName", "sn", "Surname") ' array of headers

    For j = LBound(headerArray) To UBound(headerArray)
        i = 1
        Set rng = ws.Rows(1).Find(What:=headerArray(j), LookIn:=xlValues, LookAt:=xlWhole)

        If Not rng Is Nothing Then
            For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
                If Not IsEmpty(cell.Value) Then
                    cell.Value = 1005000 + i
                    i = i + 1
                End If
            Next cell
        End If
    Next j
End Sub

Sub ChangeValueToHeaderValue()
    Dim ws As Worksheet
    Dim headerArray As Variant ' Create array of headers
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim j As Integer

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    headerArray = Array("Department", "Description", "extensionAttribute5", "City", "City_1", "Title") ' array of headers

    For j = LBound(headerArray) To UBound(headerArray)
        Set rng = ws.Rows(1).Find(What:=headerArray(j), LookIn:=xlValues, LookAt:=xlWhole)

        If Not rng Is Nothing Then
            For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
                If Not IsEmpty(cell.Value) Then
                    cell.Value = headerArray(j)
                End If
            Next cell
        End If
    Next j
End Sub

Sub ReplaceEmails()
    Dim ws As Worksheet
    Dim headerArray As Variant ' Create array of headers
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim j As Integer
    Dim atIndex As Integer
    Dim cellValue As String

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    headerArray = Array("EmailAddress", "mail", "UserPrincipalName") ' array of headers

    For j = LBound(headerArray) To UBound(headerArray)
        i = 1
        Set rng = ws.Rows(1).Find(What:=headerArray(j), LookIn:=xlValues, LookAt:=xlWhole)

        If Not rng Is Nothing Then
            For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
                If Not IsEmpty(cell.Value) Then
                    cellValue = cell.Value
                    atIndex = InStr(cellValue, "@")
                    If atIndex > 0 And atIndex < Len(cellValue) Then
                        cell.Value = 100500 + i & "@" & Mid(cellValue, atIndex + 1) ' Get all text data after "@"
                        i = i + 1
                    Else
                        cell.Value = "" ' If "@" is not found or it is in the end of the string
                        i = i + 1
                    End If
                End If
            Next cell
        End If
    Next j
End Sub

Sub CanonicalNameProc()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim cellValue As String
    Dim lastBackslashIndex As Integer

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    i = 1

    ' processing "CanonicalName"
    Set rng = ws.Rows(1).Find(What:="CanonicalName", LookIn:=xlValues, LookAt:=xlWhole)

    If Not rng Is Nothing Then
        For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
            If Not IsEmpty(cell.Value) Then
                cellValue = cell.Value
                lastBackslashIndex = InStrRev(cellValue, "/") ' Cut everything after "/" character
                If lastBackslashIndex > 0 Then
                    cell.Value = Left(cellValue, lastBackslashIndex - 1) & "/" & 100500 + i
                End If
                i = i + 1
            Else
                cell.Value = ""
            End If
        Next cell
    End If
End Sub

Sub legacyExchangeDNProc()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim cellValue As String
    Dim lastBackslashIndex As Integer

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    i = 1

    ' processing "legacyExchangeDN"
    Set rng = ws.Rows(1).Find(What:="legacyExchangeDN", LookIn:=xlValues, LookAt:=xlWhole)

    If Not rng Is Nothing Then
        For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
            If Not IsEmpty(cell.Value) Then
                cellValue = cell.Value
                lastBackslashIndex = InStrRev(cellValue, "-") ' Cut everything after "-" character
                If lastBackslashIndex > 0 Then
                    cell.Value = Left(cellValue, lastBackslashIndex - 1) & "-" & 100500 + i
                End If
                i = i + 1
            Else
                cell.Value = ""
            End If
        Next cell
    End If
End Sub

Sub DistinguishedNameProc()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim cellValue As String
    Dim equalSignIndex As Integer
    Dim commaIndex As Integer

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface
    i = 1

    ' processing "DistinguishedName"
    Set rng = ws.Rows(1).Find(What:="DistinguishedName", LookIn:=xlValues, LookAt:=xlWhole)

    If Not rng Is Nothing Then
        For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
            If Not IsEmpty(cell.Value) Then
                    cellValue = cell.Value
                    equalSignIndex = InStr(1, cellValue, "=") ' Find the place of first "="
                    commaIndex = InStr(equalSignIndex, cellValue, ",") ' Find the place of next ','
                    If equalSignIndex > 0 And commaIndex > 0 Then
                        cell.Value = Left(cellValue, equalSignIndex) & 100500 + i & Mid(cellValue, commaIndex)
                    End If
            i = i + 1
            Else
                cell.Value = ""
            End If
        Next cell
    End If
End Sub

Sub HomeDirectoryClean()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim cellValue As String

    Set ws = ThisWorkbook.Sheets("deface") ' Change your sheet name to deface

    ' processing "HomeDirectory"
    Set rng = ws.Rows(1).Find(What:="HomeDirectory", LookIn:=xlValues, LookAt:=xlWhole)

    If Not rng Is Nothing Then
        For Each cell In rng.Offset(1).Resize(ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row).Cells
            If Not IsEmpty(cell.Value) Then
                    cell.Value = ""
            End If
        Next cell
    End If
End Sub

Для запуска скрипта переместите курсор на имя функции Main() и нажмите кнопку на панели инструментов или клавишу F5.

Рис. 3. Запуск скрипта
Убедитесь, что все требуемые атрибуты обезличены.

После успешного завершения процедуры обезличивания сохраните файл книги Excel и передайте его специалистам службы поддержки.