Copy Unique Data
- Copy the complete code into a standard module, e.g.
Module1.
- Adjust the values in the constants section.
Option Explicit
Sub CopyUniqueDataValues()
' Needs the 'RefColumn', 'GetUniqueRespectiveValuesInRows'
' and 'GetRange' functions.
Const ProcTitle As String = "Copy Unique Data Values"
Const sName As String = "Sheet1"
Const suFirst As String = "A2"
Const svCol As String = "B"
Const dName As String = "Sheet1"
Const dFirst As String = "D2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create references to the Source Column Ranges and write their
' values to the Source Arrays.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sufCell As Range: Set sufCell = sws.Range(suFirst)
Dim surg As Range: Set surg = RefColumn(sufCell)
If surg Is Nothing Then
MsgBox "The unique column range is empty.", vbCritical, ProcTitle
Exit Sub
End If
Dim suData As Variant: suData = GetRange(surg)
Dim svrg As Range: Set svrg = surg.EntireRow.Columns(svCol)
Dim svData As Variant: svData = GetRange(svrg)
' Write the resulting values to the Destination Array.
Dim dData As Variant
dData = GetUniqueRespectiveValuesInRows(suData, svData)
If IsEmpty(dData) Then
MsgBox "No unique data found.", vbCritical, ProcTitle
Exit Sub
End If
' Create a reference to the Destination First Cell.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
' Clear (e.g. "D2:XFD1048576").
Dim dcrg As Range: Set dcrg = dfCell.Resize( _
dws.Rows.Count - dfCell.Row + 1, _
dws.Columns.Count - dfCell.Column + 1)
dcrg.Clear
' Write the values from the Destination Array to the Destination Range.
Dim drg As Range
Set drg = dfCell.Resize(UBound(dData, 1), UBound(dData, 2))
drg.Value = dData
' Inform.
MsgBox "Unique data values copied.", vbInformation, ProcTitle
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the respective values from the second (values) array
' of each unique value of the first (unique) array in rows
' of a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueRespectiveValuesInRows( _
ByVal suData As Variant, _
ByVal svData As Variant) _
As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim tColl As Collection
Dim suValue As Variant
Dim r As Long
Dim dcCount As Long
For r = 1 To UBound(suData)
suValue = suData(r, 1)
If Not IsError(suValue) Then
If Len(suValue) > 0 Then
If dict.Exists(suValue) Then
Set tColl = dict(suValue) ' existing collection to 'tColl'
Else
Set tColl = New Collection
End If
tColl.Add svData(r, 1)
Set dict(suValue) = tColl
If tColl.Count > dcCount Then
dcCount = tColl.Count
End If
End If
End If
Next r
If dcCount = 0 Then Exit Function ' only blanks and error values (unlikely)
Dim drCount As Long: drCount = dict.Count
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
r = 0
Dim Key As Variant
Dim Item As Variant
Dim c As Long
For Each Key In dict.Keys
r = r + 1
c = 0
For Each Item In dict(Key)
c = c + 1
dData(r, c) = Item
Next Item
Next Key
GetUniqueRespectiveValuesInRows = dData
End Function
