Как express детали моего словаря в виде массива в VBA? - PullRequest
1 голос
/ 26 марта 2020

Это продолжение вопроса, который я задавал ранее Как мне найти индекс последней строки каждого дубликата в том же столбце? . В настоящее время я пытаюсь извлечь каждое из дублированных имен, которые я уже нашел, хранящихся под ключом словаря. Но как мне извлечь и express их в виде массива, используя ключ, который я нашел ранее? Потому что в конечном итоге я хочу использовать размер массива в качестве одного из условий, чтобы скопировать весь столбец дублированных имен в другой лист, но я не смог express ключ здесь, чтобы они имели размер массива.

edit: что я имею в виду под извлечением каждого дублированного имени, где размер arr должен быть равен 4, как arr = («Джон», «Трамп», «Алиса», «Сара»), если мне удалось извлечь их из dict в массив

Dim target as long

For Target = LBound(Arr) To UBound(Arr)

изображение деталей словаря, которые проверяют наличие дублированного имени

Debug.Print Key, Dict(Key), Rng.Address

'dict (ключ) относится к последнему индексу дублированных имен, ключ относится к имени дублированное имя, Rng.address относится к диапазону, в котором находится каждое дублированное имя.

enter image description here

цель поиска массива в виде arr = (" Джон "," Трамп "," Алиса "," Сара ")

Поскольку в конечном итоге я хотел скопировать и вставить весь дубликат в разные листы, например, всю строку, состоящую из имени Джон в Джон рабочий лист, весь ро ш, который состоит из имени сара в лист сара. Следовательно, мой план размещения состоит в том, чтобы найти их индекс строки, а затем использовать массивы, чтобы проверить, существует ли их имя в arr = ("john", "sarah", "alice", "trump"), и, если они существуют, перейдите к копированию. и вставьте их в соответствующий лист. Следовательно, после того, как я получил свой rowindex от dict, я попытался интегрировать их в части arr, что приводит меня к этой проблеме ..

enter image description here

Ответы [ 2 ]

1 голос
/ 26 марта 2020

Возможно, это то, что вам нужно, хотя я не понимаю, зачем вам нужен массив.

Sub x()

Dim r As Range, dict As Object, i As Long, v

Set dict = CreateObject("Scripting.Dictionary")

For Each r In Range("A1:A9")
    dict(r.Value) = r.Address
Next r

v = dict.keys 'put the keys into an array (seems redundant to me)

For i = LBound(v) To UBound(v)
    MsgBox v(i)
Next i

End Sub

enter image description here

1 голос
/ 26 марта 2020

Чтобы заполнить столбец ключами, используйте transpose .

Sub demo()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.Add "A", 1
    dict.Add "B", 1
    dict.Add "C", 1

    Sheets("Sheet1").Range("A1").Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.keys)

End Sub

Обновление: нет необходимости копировать дубликаты имен из ключей словаря в массив, а затем использовать массив, чтобы проверить, является ли значение дубликатом, метод словаря (имя) делает это для вас.

Используя словарь для начальной строки и другой для конечной строки, легко определить диапазон повторяющихся строк для каждого имени и скопировать этот диапазон на новый лист без повторного сканирования столбца. Проверка, является ли ячейка значение существует в массиве «повторяющихся имен».

Option Explicit

Sub CopyDuplicates()

    Dim wb As Workbook, ws As Worksheet
    Dim irow As Long, iLastRow As Long

    Dim dictFirstRow As Object, dictLastRow As Object, sKey As String
    Set dictFirstRow = CreateObject("Scripting.Dictionary") ' first row for name
    Set dictLastRow = CreateObject("Scripting.Dictionary") ' last row for name

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    iLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    ' build dictionaries
    For irow = 1 To iLastRow
        sKey = ws.Cells(irow, 1)
        If dictFirstRow.exists(sKey) Then
           dictLastRow(sKey) = irow
        Else
           dictFirstRow.Add sKey, irow
           dictLastRow.Add sKey, irow
        End If
    Next

    ' copy range of duplicates
    Dim k, iFirstRow As Long, rng As Range, wsNew As Worksheet
    For Each k In dictFirstRow.keys

        iFirstRow = dictFirstRow(k)
        iLastRow = dictLastRow(k)

        ' only copy duplicates
        If iLastRow > iFirstRow Then
            Set wsNew = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
            wsNew.Name = k

            Set rng = ws.Rows(iFirstRow & ":" & iLastRow).EntireRow
            rng.Copy wsNew.Range("A1")
            Debug.Print k, iFirstRow, iLastRow, rng.Address
        End If
    Next

    MsgBox "Done"

End Sub



Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...