Vba 如何将包含多个值(逗号分隔)的单元格拆分为单独的行?
我正在处理一个数据示例,我想根据逗号分隔符将其分成几行。拆分前Excel中的我的数据表如下所示: 我想开发VBA代码来拆分C列(“公司联系人”)中的值,并为每个“公司联系人”创建单独的行 到目前为止,我已经成功地将C列中的值拆分为单独的行。但是,我还没有将D列(关系的长度)和E列(关系的强度)中的值进行拆分,以便用逗号分隔的每个值对应于C列中相应的触点 下面是我用来拆分单元格的代码示例。这段代码的局限性在于它没有拆分表中的其他列,只拆分了一列 如何使此代码能够拆分其他列中的值Vba 如何将包含多个值(逗号分隔)的单元格拆分为单独的行?,vba,excel,split,Vba,Excel,Split,我正在处理一个数据示例,我想根据逗号分隔符将其分成几行。拆分前Excel中的我的数据表如下所示: 我想开发VBA代码来拆分C列(“公司联系人”)中的值,并为每个“公司联系人”创建单独的行 到目前为止,我已经成功地将C列中的值拆分为单独的行。但是,我还没有将D列(关系的长度)和E列(关系的强度)中的值进行拆分,以便用逗号分隔的每个值对应于C列中相应的触点 下面是我用来拆分单元格的代码示例。这段代码的局限性在于它没有拆分表中的其他列,只拆分了一列 如何使此代码能够拆分其他列中的值 Sub Spl
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
您不仅应该迭代行,还应该迭代列,并检查每个单元格中是否有这样的逗号。当一行中至少有一个单元格有逗号时,应将其拆分 然后可以插入该行,并在新创建的行中复制逗号之前的部分,同时从原始行中删除该部分,然后将原始行上移一个索引 在插入行时,还应注意增加要遍历的行数,否则将执行不完整的作业 以下是您可以使用的代码:
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
子Splt()
尺寸LR为长,LC为长,r为长,c为长,pos为长
Dim v作为变体
Application.ScreenUpdating=False
LR=单元格(Rows.Count,1).End(xlUp).Row
LC=单元格(1,Columns.Count).End(xlToLeft).Column
r=2
Do While r我会采用一种方法,使用用户定义的对象(类)和字典来收集和重新组织数据。使用可理解的名称,以便于将来的维护和调试
此外,通过使用VBA数组,宏的执行速度应该比多次读取和写入工作表快得多
然后将数据重新编译成所需的格式
我定义的两个类是
- 站点(我假设每个站点只有一个站点联系人,尽管这很容易更改,如果需要的话),包含以下信息:
- 站点名称
- 站点关键联系人
- 还有一本公司联系信息字典
- 公司联系人,其中包含以下信息:
- 名字
- 关系长度
- 关系强度
我会检查以确保在最后三列中有相同数量的条目
正如您所看到的,如果需要的话,向任何一个类添加额外的信息都是相当简单的
输入两个类模块和一个常规模块
重命名类模块,如注释中所示
确保设置对Microsoft脚本运行时的引用,以便能够使用Dictionary对象
此外,您可能需要为源代码/结果工作表/范围重新定义wsSrc
、wsRes
和rRes
。为了方便起见,我把它们放在同一张工作表上,但没有必要这样做
班级单元1
班级模块2
正则模
谢谢,你的回答非常有用!非常感谢你的帮助!
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
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