Excel VBA：将信息强制转换为逗号分隔的字符串

编程问答 2022-05-23

问题描述

我有两个 Excel 工作表（“Sheet1”和“Sheet2”）。 Sheet2 包含我想根据 ID 分组并显示在“Sheet1”中的原始数据。也就是说，我想根据 ID 强制转换 'Feed' 和 'NUMB'，并将 'Feed' 和 'NUMB' 存储为逗号分隔的字符串（参见下面的示例数据）。

这个过程需要是动态的，即如果我在 Sheet2 中输入新数据，Sheet1 中显示的信息会自动更新。

请注意，我想使用 VBA 来执行此操作，我绝对是初学者（Microsoft Excel 2019 和非英语）。我一直在尝试使用 VBA 反向执行此操作（即将根据 Sheet1 存储的数据拆分为 Sheet2），但是我的试验没有成功。我通常不喜欢在 Excel 中工作，尽管目前的情况迫使我这样做

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       |

解决方法

请尝试下一个代码。它从“O1”开始返回。它可以在您需要的任何地方返回：

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,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,2))),"|")
        dict(arr(i,2)) = arrInt(0) & "," & arr(i,3) & "|" & arrInt(1) & ",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,"|")(1)
    arrFin(3,k) = Split(dict.items(i),"|")(0)
    arrFin(4,"|")(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

如果您不知道如何添加必要的引用，请先运行下一个代码，它会自动添加它。之后保存工作簿...

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
coercecommaexcelexcelstringstringvba