excelvbastringcsvcoerce

Excel VBA: coerce information into comma separated strings


I have two excel worksheets ("Sheet1" and "Sheet2"). Sheet2 contains rawdata that I want to group and present in "Sheet1" based on ID. That is, I want to coerce 'FEED' and 'NUMB' based on ID, and store 'FEED' and 'NUMB' as comma separated strings (see example data below).

This procedure needs to be dynamic, i.e. if I enter new data into Sheet2, the information presented in Sheet1 is updated automatically.

Note that I'd like to do this using VBA, in which I am an absolute beginner (Microsoft Excel 2019 and non-english). I've been trying to do this in reverse (i.e. splitting data stored according to Sheet1 to Sheet2) using VBA, however I've been unsuccessfull in my trials. I generally do not prefer working in Excel although current circumstances forces my hand at this

Sheet2

| Group | ID    | FEED  | NUMB |
|:-----:|:-----:|:-----:|:----:|
| B     | B1    | C1    | 1    |
| B     | B2    | L3    | 43   |
| B     | B3    | K12   | 101  |
| B     | B1    | G1    | 86   |
| B     | B3    | H2    | 109  |
| C     | C1    | L3    | 23   |
| C     | C2    | G1    | 24   |
| C     | C1    | L4    | 54   |
| C     | C1    | K8    | 56   |

Sheet1

| Group | ID | FEED     | NUMB     |
|:-----:|:--:|:--------:|:--------:|
| B     | B1 | C1,G1    | 1,86     |
| B     | B2 | L3       | 43       |
| B     | B3 | K12,H2   | 101,109  |
| C     | C1 | L3,L4,K8 | 23,54,56 |
| C     | C2 | G1       | 24       |


Solution

  • Please, try the next code. It returns starting from "O1". It can return anywhere you need:

    Sub TestProcessCommaSep()
     'It needs a reference to 'Microsoft Scripting Runtime'
     Dim sh As Worksheet, lastR As Long, arr, arrFin, arrInt
     Dim dict As New Scripting.Dictionary, i As Long, k As Long
     
     Set sh = ActiveSheet 'use here the sheet you need
     lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
     
     arr = sh.Range("A2:D" & lastR).value   'put the range to be processed in an array
     ReDim arrFin(1 To 4, 1 To UBound(arr)) 'redim the final array to make space for maximum
     
     For i = 1 To UBound(arr) 'iterate between arr elements
        If Not dict.Exists(arr(i, 1) & "|" & arr(i, 2)) Then 'if the key does not exist:
            dict.Add arr(i, 1) & "|" & arr(i, 2), arr(i, 3) & "|" & arr(i, 4) 'it is created
        Else
            'add to the existing key the values in columns 3 and 4:
            arrInt = Split(dict((arr(i, 1) & "|" & arr(i, 2))), "|")
            dict(arr(i, 1) & "|" & arr(i, 2)) = arrInt(0) & "," & arr(i, 3) & "|" & arrInt(1) & "," & arr(i, 4)
        End If
     Next i
     'fill the final array:
     For i = 0 To dict.count - 1
        k = k + 1
        arrFin(1, k) = Split(dict.Keys(i), "|")(0)
        arrFin(2, k) = Split(dict.Keys(i), "|")(1)
        arrFin(3, k) = Split(dict.items(i), "|")(0)
        arrFin(4, k) = Split(dict.items(i), "|")(1)
     Next
     ReDim Preserve arrFin(1 To 4, 1 To k) 'keep only the elements keeping values
     'Put the header, dropping the array elements at once:
     With sh.Range("O1")
        .Resize(1, 4).value = sh.Range("A1:D1").value
        With .Offset(1).Resize(k, 4)
            .value = Application.Transpose(arrFin)
            .EntireColumn.AutoFit
        End With
     End With
    End Sub
    

    If you do not know how to add the necessary reference, please firstly run the next code, which will automatically add it. Save the workbook after that...

    Sub addScrRunTimeRef()
      'Adding a reference to 'Microsoft Scripting Runtime':
      'In case of error ('Programmatic access to Visual Basic Project not trusted'):
      'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
      '         check "Trust access to the VBA project object model"
      Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
    End Sub