如何将包含多个值（逗号分隔）的单元格拆分成单独的行？

我正在处理一个数据样本，我想根据逗号分隔符将其分成几行。 Excel中的数据表在拆分之前看起来像这样：

我想开发VBA代码来拆分C列（“公司联系点”）中的值，并为每个“公司联系点”创build单独的行。

到目前为止，我已经设法将C列中的值拆分成不同的行。 然而，我还没有设法在列D（关系长度）和E（关系强度）中分割值，以便用逗号分隔的每个值对应于列C中其各自的接触。

你会在下面find我借来分割我的单元的代码样本。 这个代码的限制是它没有拆分我的表中的其他列，只是一个。

我怎样才能让这段代码工作分裂在其他列的值？

Sub Splt() Dim LR As Long, i As Long Dim X As Variant Application.ScreenUpdating = False LR = Range("A" & Rows.Count).End(xlUp).Row Columns("A").Insert For i = LR To 1 Step -1 With Range("B" & i) If InStr(.Value, ",") = 0 Then .Offset(, -1).Value = .Value Else X = Split(.Value, ",") .Offset(1).Resize(UBound(X)).EntireRow.Insert .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X) End If End With Next i Columns("B").Delete LR = Range("A" & Rows.Count).End(xlUp).Row With Range("B1:C" & LR) On Error Resume Next .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" On Error GoTo 0 .Value = .Value End With Application.ScreenUpdating = True End Sub 

Answer 1

你不仅应该迭代行，而且还要遍历列，并检查每个单元格是否有这样的逗号。 当至less有一个单元格中有一个逗号时，它应该被分割。

然后，您可以插入行，并在新创build的行的逗号前面复制零件，同时从原始行中删除该零件，然后向上移动一个索引。

在插入行时，还应该注意增加要遍历的行数，否则您将执行不完整的工作。

这里是你可以使用的代码：

 Sub Splt() Dim LR As Long, LC As Long, r As Long, c As Long, pos As Long Dim v As Variant Application.ScreenUpdating = False LR = Cells(Rows.Count, 1).End(xlUp).Row LC = Cells(1, Columns.Count).End(xlToLeft).Column r = 2 Do While r <= LR For c = 1 To LC v = Cells(r, c).Value If InStr(v, ",") Then Exit For ' we need to split Next If c <= LC Then ' We need to split Rows(r).EntireRow.Insert LR = LR + 1 For c = 1 To LC v = Cells(r + 1, c).Value pos = InStr(v, ",") If pos Then Cells(r, c).Value = Left(v, pos - 1) Cells(r + 1, c).Value = Trim(Mid(v, pos + 1)) Else Cells(r, c).Value = v End If Next End If r = r + 1 Loop Application.ScreenUpdating = True End Sub 

Answer 2

我将使用用户定义的对象（类）和字典来调整方法来收集和重组数据。 使用可理解的名称，以便日后维护和debugging。

而且，通过使用VBA数组，macros应该比执行多次读取和写入/从工作表执行得更快

然后将数据重新编译为所需的格式。

我已经定义了两个类

• 网站（我假定每个网站只有一个网站联系人，虽然很容易更改，如果需要）与信息：

  • 网站名称
  • 网站主要联系人
  • 和公司联系信息字典

• 公司联系人，其中的信息

  • 名称
  • 关系的长度
  • 关系的力量

我会检查以确保最后三列中有相同数量的条目。

正如你所看到的，如果需要的话，向其中任何一个类添加额外的信息都是相当简单的。

input两个类模块和一个常规模块按照注释中的指示重命名类模块

请务必设置对Microsoft脚本运行时的引用，以便能够使用Dictionary对象。

此外，你可能会想重新定义你的源/结果工作表/范围的wsSrc ， wsRes和rRes 。 为了方便，我把它们放在同一张工作表上，但是没有必要。

课堂单元1

 Option Explicit 'Rename this to: cSite 'Assuming only a single Site Key Contact per site Private pSite As String Private pSiteKeyContact As String Private pCompanyContactInfo As Dictionary Private pCC As cCompanyContact Public Property Get Site() As String Site = pSite End Property Public Property Let Site(Value As String) pSite = Value End Property Public Property Get SiteKeyContact() As String SiteKeyContact = pSiteKeyContact End Property Public Property Let SiteKeyContact(Value As String) pSiteKeyContact = Value End Property Public Property Get CompanyContactInfo() As Dictionary Set CompanyContactInfo = pCompanyContactInfo End Property Public Function AddCompanyContactInfo(ByVal CompanyContact As String, _ ByVal RelationshipLength As String, ByVal RelationshipStrength As String) Set pCC = New cCompanyContact With pCC .CompanyContact = CompanyContact .LengthOfRelationship = RelationshipLength .StrengthOfRelationship = RelationshipStrength pCompanyContactInfo.Add Key:=.CompanyContact, Item:=pCC End With End Function Private Sub Class_Initialize() Set pCompanyContactInfo = New Dictionary End Sub 

class级模块2

 Option Explicit 'Rename to: cCompanyContact Private pCompanyContact As String Private pLengthOfRelationship As String Private pStrengthOfRelationship As String Public Property Get CompanyContact() As String CompanyContact = pCompanyContact End Property Public Property Let CompanyContact(Value As String) pCompanyContact = Value End Property Public Property Get LengthOfRelationship() As String LengthOfRelationship = pLengthOfRelationship End Property Public Property Let LengthOfRelationship(Value As String) pLengthOfRelationship = Value End Property Public Property Get StrengthOfRelationship() As String StrengthOfRelationship = pStrengthOfRelationship End Property Public Property Let StrengthOfRelationship(Value As String) pStrengthOfRelationship = Value End Property 

常规模块

 Option Explicit 'Set Reference to Microsoft Scripting Runtime Sub SiteInfo() Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range Dim vSrc As Variant, vRes As Variant Dim cS As cSite, dS As Dictionary Dim I As Long, J As Long Dim V As Variant, W As Variant, X As Variant 'Set source and results worksheets and results range Set wsSrc = Worksheets("Sheet4") Set wsRes = Worksheets("Sheet4") Set rRes = wsRes.Cells(1, 10) 'Get source data With wsSrc vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 5).End(xlUp)) End With 'Split and collect the data into objects Set dS = New Dictionary For I = 2 To UBound(vSrc, 1) 'skip first row Set cS = New cSite V = Split(vSrc(I, 3), ",") W = Split(vSrc(I, 4), ",") X = Split(vSrc(I, 5), ",") If Not UBound(V) = UBound(W) And UBound(V) = UBound(X) Then MsgBox "Mismatch in Company Contact / Length / Strength" Exit Sub End If With cS .Site = vSrc(I, 1) .SiteKeyContact = vSrc(I, 2) For J = 0 To UBound(V) If Not dS.Exists(.Site) Then .AddCompanyContactInfo Trim(V(J)), Trim(W(J)), Trim(X(J)) dS.Add .Site, cS Else dS(.Site).AddCompanyContactInfo Trim(V(J)), Trim(W(J)), Trim(X(J)) End If Next J End With Next I 'Set up Results array I = 0 For Each V In dS I = I + dS(V).CompanyContactInfo.Count Next V ReDim vRes(0 To I, 1 To 5) 'Headers For J = 1 To UBound(vRes, 2) vRes(0, J) = vSrc(1, J) Next J 'Populate the data I = 0 For Each V In dS For Each W In dS(V).CompanyContactInfo I = I + 1 vRes(I, 1) = dS(V).Site vRes(I, 2) = dS(V).SiteKeyContact vRes(I, 3) = dS(V).CompanyContactInfo(W).CompanyContact vRes(I, 4) = dS(V).CompanyContactInfo(W).LengthOfRelationship vRes(I, 5) = dS(V).CompanyContactInfo(W).StrengthOfRelationship Next W Next V 'Write the results Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes With .Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter End With .EntireColumn.AutoFit End With End Sub