VBA: adding delimited string to a dynamic array

[jscranton]

Working on a new project and thinking about the best way to achieve something.

I have a range of cell that each contain a string of names delimited by semi-colons such as "Last, First;Last2, First2;Last3, First3". In the end, I want each name String to be added to an array (I will dedupe the array once all values have been added).

I have used the split function before and I think perhaps I could use the copy array function to add them to the destination array? So, it would look something like:

 Dim nameString As String
 Dim tempArray() As String


For i = 2 to LastRowOfRange

   nameString = CSTR(Range("A"& i).Value)
   tempArray  = SPLIT(nameString,";")

   P[COLOR=#003366]ublic Function CopyArray(DestinationArray As Variant, tempArray As Variant, _
        Optional NoCompatabilityCheck As Boolean = False) As Boolean[/COLOR]

Next i


End Sub

Assuming this works, is there an easier ("cleaner") way to achieve this?

 

[hiker95]

jscranton,

Sample raw data:

Excel 2007
	A	B	C
1	Title A
2	Last, First;Last2, First2;Last3, First3
3	Last2, First2;Last3, First3;Last, First
4	Last5, First5;Last6, First6;Last8, First8
5	Last, First;Last2, First2;Last3, First3
6	Last2, First2;Last3, First3;Last, First
7	Last7, First7;Last6, First6;Last8, First8
8
9
Sheet1

After the macro:

Excel 2007
	A	B	C
1	Title A		Uniques
2	Last, First;Last2, First2;Last3, First3		Last, First
3	Last2, First2;Last3, First3;Last, First		Last2, First2
4	Last5, First5;Last6, First6;Last8, First8		Last3, First3
5	Last, First;Last2, First2;Last3, First3		Last5, First5
6	Last2, First2;Last3, First3;Last, First		Last6, First6
7	Last7, First7;Last6, First6;Last8, First8		Last7, First7
8			Last8, First8
9
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub GetUniques()
' hiker95, 02/01/2014, ME754614
Dim d As Object, a As Variant, i As Long, s, ii As Long
Set d = CreateObject("Scripting.Dictionary")
a = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = LBound(a, 1) To UBound(a, 1)
  If InStr(a(i, 1), ";") = 0 And a(i, 1) <> "" Then
    If Not d.Exists(a(i, 1)) Then
      d(a(i, 1)) = 1
    End If
  ElseIf InStr(a(i, 1), ";") > 0 Then
    s = Split(a(i, 1), ";")
    For ii = LBound(s) To UBound(s)
      If Not d.Exists(s(ii)) Then
        d(s(ii)) = 1
      End If
    Next ii
  End If
Next i
Columns(3).Clear
Cells(1, 3) = "Uniques"
Range("C2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("C2:C" & d.Count + 1).Sort key1:=Range("C2"), order1:=1
Columns(3).AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetUniques macro.

 

[Rick Rothstein]

jscranton,

Sample raw data:

Excel 2007

	A	B	C
Last, First;Last2, First2;Last3, First3
Last2, First2;Last3, First3;Last, First
Last5, First5;Last6, First6;Last8, First8
Last, First;Last2, First2;Last3, First3
Last2, First2;Last3, First3;Last, First
Last7, First7;Last6, First6;Last8, First8

<tbody>
[TD="align: center"]1[/TD]
[TD="align: center"]Title A[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]5[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]6[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]7[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

</tbody>

Sheet1
​

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub GetUniques()
' hiker95, 02/01/2014, ME754614
Dim d As Object, a As Variant, i As Long, s, ii As Long
Set d = CreateObject("Scripting.Dictionary")
a = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = LBound(a, 1) To UBound(a, 1)
  If InStr(a(i, 1), ";") = 0 And a(i, 1) <> "" Then
    If Not d.Exists(a(i, 1)) Then
      d(a(i, 1)) = 1
    End If
  ElseIf InStr(a(i, 1), ";") > 0 Then
    s = Split(a(i, 1), ";")
    For ii = LBound(s) To UBound(s)
      If Not d.Exists(s(ii)) Then
        d(s(ii)) = 1
      End If
    Next ii
  End If
Next i
Columns(3).Clear
Cells(1, 3) = "Uniques"
Range("C2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("C2:C" & d.Count + 1).Sort key1:=Range("C2"), order1:=1
Columns(3).AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetUniques macro.

IF the OP will always be using XL2007 or newer, then we can remove the loops and Dictionary object from your code and use some built-in functionality offered by these versions... should speed things up some as well I would imagine.

Sub GetUniques()
  Dim AllNames As String, IndividualNames() As String
  AllNames = Join(Application.Transpose(Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value), ";")
  IndividualNames = Split(AllNames, ";")
  Columns("C").Clear
  Range("C1").Value = "Uniques"
  With Range("C2:C" & UBound(IndividualNames) + 1)
    .Value = Application.Transpose(IndividualNames)
    .RemoveDuplicates Columns:=1, Header:=xlNo
    .Sort key1:=Range("C2"), Order1:=1
  End With
  Columns("C").AutoFit
End Sub