如何单元格内多个姓名整理到一个列

liuyan819

Sub Splitcontent()
For a = [B65536].End(xlUp).Row To 2 Step -1
    b = UBound(Split(Range("B" & a).Value, "、"))     '取得分隔符
        If b > 0 Then
            Cells(a, 1).Offset(1, 0).Resize(b, 1).EntireRow.Insert    '在第当前行以下插入b行，Resize为扩展区域
            Range(a + 1 & ":" & a + b) = Range(a & ":" & a).Value     '复制行
            s = Split(Range("B" & a).Value, "、")     '指定分隔符
            For c = b To 0 Step -1
                Range("B" & a).Offset(c, 0).Value = s(c)
            Next
        End If
Next
End Sub

[ 本帖最后由 liuyan819 于 2010-8-29 09:59 编辑 ]

hopeson2010

好方法，学习了！

liuyan819

来个全的，合并与分解。
Sub Splitcontent() '分解单元格
For a = [B65536].End(xlUp).Row To 2 Step -1
    b = UBound(Split(Range("B" & a).Value, "、"))     '取分隔符
        If b > 0 Then
            Cells(a, 1).Offset(1, 0).Resize(b, 1).EntireRow.Insert    '在第当前行以下插入b行，Resize为扩展区域
            Range(a + 1 & ":" & a + b) = Range(a & ":" & a).Value     '复制行
            s = Split(Range("B" & a).Value, "、")     '指定分隔符
            For c = b To 0 Step -1
                Range("B" & a).Offset(c, 0).Value = s(c)
            Next
        End If
Next
End Sub
Sub MergeSameCells() '合并单元格
    Dim Irow As Integer, m%
    Dim s As String, c As Range
    Application.DisplayAlerts = False
    With ActiveSheet                  '合并第一列
         Irow = .Range("A65536").End(xlUp).Row
         For i = Irow To 2 Step -1
             If .Cells(i, 1).Value = .Cells(i - 1, 1).Value Then
                .Range(.Cells(i - 1, 1), Cells(i, 1)).Merge
             End If
         Next
     End With
     Application.DisplayAlerts = True
     
     
For i = 3 To [b65535].End(xlUp).Row - 1
j = Cells(i, 1).MergeArea.Count
Range(Cells(i, 2), Cells(i + j - 1, 2)).Select
       For Each c In Selection           '合并第二列
           s = s & c.Value & "、"
       Next
       Application.DisplayAlerts = False
       Selection.Merge
       m = UBound(Split(s, "、"))
       s = Application.WorksheetFunction.Substitute(s, "、", "", m)
       Selection.Value = s
       Application.DisplayAlerts = True
       If j <> 1 Then Rows(i + 1 & ":" & i + j - 1).Delete
      
s = ""
       If Cells(i, 1) = "" Then Exit For
Next

     
End Sub

ytji

七楼真强大啊

lb_bn

学习七楼老师的手动操作。

mm050610

学习下，谢谢分享！

laowuwyx

原帖由 yyqq16888 于 2010-8-28 21:52 发表
特殊问题，特殊处理：
1、先把两个字姓名加上空格填为三个汉字宽度（操作完后可用查找替换把空格去掉）。
2、把“、”替换掉。
3、把A列姓名数填为跟B列姓名数相同，用公式“=REPT(A3,LEN(B3)/3)”在辅助列操作后 ...

这个好，单纯用公式来处理不晓得有多麻烦。

vic0321

谢谢啦，好帖子，学习了

冬恋

七楼厉害，又学习了！

冬恋

4、调整B列列宽为三个汉字，编辑——填充——内容重排。
求在office2007中该功能是在哪里？