[已解决]如何将一个单元格里的数据按“；”分开并自动分行，如附件。

ipaab

如何将一个单元格里的数据按“；”分开并自动分行，如附件。 Hjl5vUll.rar (1.95 KB, 下载次数: 58)

2008-3-20 10:17 上传

点击文件名下载附件
如何将一个单元格里的数据按“；”分开并自动分行，如附件。
谁帮忙看下，谢谢

最佳答案

月排行榜 / 总排行榜

oobird

2008-3-20 15:18

Sub aa()
Dim i%, j%, k%, arr(1 To 1000, 1 To 2)
For i = 1 To 3
If InStr(Cells(i, 2), ";") > 0 Then
b = Split(Cells(i, 2), ";")
For j = 0 To UBound(b)
If b(j) <> "" Then
k = k + 1
arr(k, 1) = Cells(i, 1): arr(k, 2) = b(j)
End If
Next j
End If
Next i
[a10].Resize(k, 2) = arr
End Sub

跳转到最佳答案楼层

tonyibm

Sub aa()
Dim x, x1, x2, x3, z, r, r1 As Long, y, p%

Application.DisplayAlerts = False
On Error Resume Next

Columns(2).TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote
x = [a65536].End(xlUp).Row
y = Application.WorksheetFunction.CountA(Columns(1))

For z = 1 To y
    p = Application.WorksheetFunction.CountA(Rows(z))
    Range(Cells(z, 2), Cells(z, p)).Copy
    r = [b65536].End(xlUp).Row
    Cells(r + 2, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    r1 = [b65536].End(xlUp).Row
    x1 = [a65536].End(xlUp).Row
    Range(Cells(x1 + 2, 1), Cells(r1, 1)).Value = Cells(z, 1).Value
Next z

x2 = [a65536].End(xlUp).Row

For x3 = x + 2 To x2
    If Application.WorksheetFunction.CountA(Rows(x3)) = 0 Then
        Rows(x3).Delete
    End If
Next x3

Application.DisplayAlerts = True
End Sub

试一下看行不行，

ipaab

很感谢你的帮忙，但是结果并不是我想要的

lllllllll

Sub aa()
Dim r%, i%, l%, x%, n%
i = 0
For r = 1 To 3
If r = 1 Then
    l = 10
Else
    l = 0
End If
b = Split(Range("b" & r) & ";", ";")
For x = 1 To UBound(b)
    If b(x) <> "" Then n = n + 1
Next x
Range("b" & i + l).Resize(UBound(b), 1) = WorksheetFunction.Transpose(b)
Range("a" & i + l).Resize(n + 1, 1) = Range("a" & r)
n = 0
i = Range("b65536").End(xlUp).Row + 1
Next
End Sub
捣腾的晕晕的[em01]

oobird

Sub aa()
Dim i%, j%, k%, arr(1 To 1000, 1 To 2)
For i = 1 To 3
If InStr(Cells(i, 2), ";") > 0 Then
b = Split(Cells(i, 2), ";")
For j = 0 To UBound(b)
If b(j) <> "" Then
k = k + 1
arr(k, 1) = Cells(i, 1): arr(k, 2) = b(j)
End If
Next j
End If
Next i
[a10].Resize(k, 2) = arr
End Sub

ipaab

非常感谢各位的热心帮助。已经解决问题了。

[em02]

ivy475

我也想请教另外一种拆分（按单元格数量拆分行），各位大神帮忙看一下！

suye1010

ivy475 发表于 2014-1-22 16:48
我也想请教另外一种拆分（按单元格数量拆分行），各位大神帮忙看一下！

1. Sub Test()
   
2. Dim arr0, arr, i, j, k
   
3. arr0 = Range("A1:B3")
   
4. ReDim arr(1 To 2, 1 To 1)
   
5. For i = 1 To UBound(arr0)
   
6. For j = 1 To arr0(i, 2)
   
7. k = k + 1
   
8. ReDim Preserve arr(1 To 2, 1 To k)
   
9. arr(1, k) = arr0(i, 1)
   
10. arr(2, k) = 1
    
11. Next j
    
12. Next i
    
13. Range("A5").Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
    
14. End Sub

复制代码

ivy475

版主，程序我还想改一下，如附件，您看能否实现！

卡图阿里

JK5368|||587201
A少帅：N1323|||3609590
A小哲36866|||36652455
辽J36D78—大亮|||39211796
流金歲月|||40939057
辽J22E62—红色|||44855208
A谷子辽JN0175|||67168437
FX▄︻┳═|||84818482
这样的数据怎么分开的呀，中间的|||两边数据分开，好像很有难度？？