#excel #vba
Вопрос:
У меня есть повторяющиеся значения в столбце (D).
Как извлечь уникальные значения из столбца D и объединить в одну ячейку (H1) без потери данных с помощью vba
например: «J10P , G345 , R1 , J10G»
Комментарии:
1. Что вы пробовали до сих пор? Где ты попал в беду? Пожалуйста, включите это в свой вопрос.
2. Используйте коллекцию или Словарь сценариев.
3. Я попробовал этот код для извлечения уникальных значений, но он не точен: таблица активов. Столбцы(4). Действие расширенного фильтра:=xlFilterCopy, CopyToRange:=Таблица активов. Диапазон(«H1»), Уникальный:=True
4. Пример ожидаемого результата был бы полезен. Но, похоже, это можно легко сделать в Power Query путем группировки.
Ответ №1:
Объединение уникальных Значений (Словарь)
- Измените значения в разделе константы и в рабочей книге.
Option Explicit
Sub concatUnique()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const dName As String = "Sheet1"
Const dFirst As String = "H1"
Const dDelim As String = ", "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Range.
Dim srg As Range
Dim srCount As Long
With wb.Worksheets(sName).Range(sFirst)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
srCount = lCell.Row - .Row 1
Set srg = .Resize(srCount)
End With
' Write values from Source Range to Source Data Array.
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
' Write unique values from Source Data Array to Unique Dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(sData, 1)
Key = sData(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Empty
End If
End If
Next r
If dict.Count > 0 Then
' Create a reference to the Destination Cell (Range).
Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
' Write the unique values from Unique Dictionary to Resulting String.
Dim Result As String: Result = Join(dict.Keys, dDelim)
' Write the result to the Destination Cell (Range).
dCell.Value = Result
' or in one line:
'wb.Worksheets(dName).Range(dFirst).Value = Join(dict.Keys, dDelim)
End If
End Sub
Комментарии:
1. Я получил эту ошибку» Несоответствие типа» в этой строке Ключ = sData(r, 1)
2. Измените
Dim Key As Long
наDim Key As Variant
. Извините.