excel vba 将数据用逗号分割，并插入到不同行

Question

如何将excel中数字分离到不同行
24.5,23.3,24
25,36,56,33,66
23,33
将以上不同行的数据用逗号分割开，然后插入到不同行
举例：
A列 B列
1 23.5(2)(1),34.33(a)
2 44,45,46,43,34
3 77
......
分割后变为：
A列 B列
1 23.5(2)(1)
1 34.33(a)
2 44
2 45
2 46
2 43
2 34
3 77
.....
实际中的表格数据有一万多条，所以要通用

Answer 1

代码如下：

Sub aa()
Dim i, j, k As Integer
Dim s As String
For j = 1 To 3
s = Cells(j, 1) & ","
For i = 1 To Len(s) - Len(Replace(s, ",", ""))
k = InStr(1, s, ",")
Cells(j, i + 1) = 1 * Left(s, k - 1)
s = Mid(s, k + 1, Len(s) - k)
Next i
Next j
End Sub

A1：A3分别输入上面的三行数字后，运行即可达到要求。

追问

这个分割后的数据是在一行啊，我需要的是在同列不同行。您有办法吗？

追答

修改后代码如下：

Sub aa()
Dim i, j, k, m, n As Integer
Dim s As String
For i = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
m = Len(Sheet1.Cells(i, 1)) - Len(Replace(Sheet1.Cells(i, 1), ",", "")) + 1
n = WorksheetFunction.CountA(Sheet2.Range("A:A"))
s = Sheet1.Cells(i, 1) & ","
For j = n + 1 To n + m
k = InStr(1, s, ",")
Sheet2.Cells(j, 1) = i
Sheet2.Cells(j, 2) = Replace(Left(s, k), ",", "")
s = Mid(s, k + 1, Len(s) - k)
Next j
Next i
End Sub

Sheet1A列中输入原始数据，运行程序后结果输出在Sheet2中。

Answer 2

选中单元格 》 数据 》分列 》分隔符号 》下一步 》逗号 》完成

追问

这个我知道的，这样完成后数据是在一行中显示

追答

无需那么复杂的代码，简单代码就可以解决了，假设原始数据在sheet1表（a列为编号，b列为数据），提取到sheet2表：

Sub aa()
Dim i, c, j, n, arr
i = 1
n = Sheets("sheet1").Range("b65536").End(xlUp).Row '假设原始数据放在sheet1工作表
MsgBox "原始数据共 " & n & " 行"
For Each c In Sheets("sheet1").Range("b1:b" & n)
If c = "" Then GoTo line1
a = Cells(c.Row, 1)
arr = Split(c, ",")
For j = 0 To UBound(arr)
Sheets("Sheet2").Cells(i + j, 1) = a '提取数据到sheet2工作表
Sheets("Sheet2").Cells(i + j, 2) = arr(j)
Next j
i = i + UBound(arr) + 1
line1:
Next c
End Sub

Answer 3

Sub Chai_fen()
Dim Str1 As String
Dim Str2 As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim L As Integer
Dim t1 As Long
Dim t2 As Long
Dim t3 As Long
Dim t4 As Long
Dim f As Boolean
'''''''''''''''''''''''''''''''''''
Dim ALStr As String
Dim ARStr As String
Dim ALoop1 As Long
Dim ATmpStr As String
Dim ATmp1 As Long
Dim ATmp2 As Long
Dim Tx As Long

'''''''''''''''''''''''''''''''''''
On Error Resume Next

f = True
t1 = Selection.Row + UBound(Selection.Value2)
If t1 > 65535 Then
t1 = 65535
Else
t1 = Selection.Row
Tx = UBound(Selection.Value2)

GoTo S1
End If

t2 = Selection.Row
t3 = Selection.Column

If Selection(1, UBound(Selection.Value2)) = "" Then

Range(Cells(t1, t3), Cells(t1, t3)).Select
Selection.End(xlUp).Select
t4 = Selection.Row
Range(Cells(t2, t3), Cells(t4, t3)).Select

t1 = Selection.Row + UBound(Selection.Value2)
If t1 = 65535 Then t1 = 1
Tx = UBound(Selection.Value2)
End If

Start1:

S1:

Str1 = Selection(1, 1)
''''''''''''''''''''''''''''''''''''''''''''''

While InStr(1, Str1, "-")

ATmpStr = ""
ATmp1 = InStr(1, Str1, "-")
ALoop1 = ATmp1
ATmp2 = ATmp1

AL1:

ATmpStr = Mid(Str1, ATmp1 - 1, 1)
ATmp1 = ATmp1 - 1

If ATmp1 <> 0 And ATmpStr <> "," Then GoTo AL1
ALStr = Mid(Str1, ATmp1 + 1, ALoop1 - ATmp1 - 1)

AL2:

ATmpStr = Mid(Str1, ATmp2 + 1, 1)
ATmp2 = ATmp2 + 1

If ATmp2 <> Len(Str1) And ATmpStr <> "," Then GoTo AL2
If ATmpStr = "," Then ATmp2 = ATmp2 - 1
ARStr = Mid(Str1, ALoop1 + 1, ATmp2 - ALoop1)

Str1 = Left(Str1, ATmp1) + Chai(ALStr, ARStr) + Right(Str1, Len(Str1) - ATmp2)

Wend

'''''''''''''''''''''''''''''''''''''''''''''''''''
j = 0
i = 1
While i <> 0
i = InStr(i + 1, Str1, ",", vbTextCompare)
j = j + 1

Wend

k = j
k = k - 1
t1 = t1 + k
i = Selection.Row
j = Selection.Column

If k > 0 Then Rows(i + 1 & ":" & i + k).Insert Shift:=xlDown

k = 1
L = 0
Str1 = Replace(Str1, ",", Chr(13) & Chr(10))
Open "tmp.txt" For Output As #1
Print #1, Str1

Close 1

Open "tmp.txt" For Input As #2
While EOF(2) = False
Line Input #2, Str1
Cells(i, j) = Str1
i = i + 1
Wend
Close 2

End2:

Cells(i, j).Select

If i < t1 + Tx Then GoTo Start1

Cells(t1, j).Select

End Sub

Private Function Chai(LStr As String, RStr As String) As String
Dim Origin As String

Dim Loop1 As Integer
Dim Tmp As Long

Dim TmpStr As String
Dim LTmpStr As String
Dim AddZero As String

Dim r As Long
Dim t As Long

Origin = LStr
r = 1
L: If Cells(r, 1) <> "" Or Cells(r + 1, 1) <> "" Then r = r + 1: GoTo L
L2:
Cells(r, 1) = LStr
Range("A" & CStr(r)).AutoFill Destination:=Range("A" & CStr(r) & ":" & "A" & CStr(r + 1)), Type:=xlFillDefault
LStr = Cells(r + 1, 1)
Origin = Origin + "," + LStr

t = t + 1
If t = 100 Then
Cells(r, 1) = ""
Cells((r + 1), 1) = ""
MsgBox "拆分" & RStr & "错误,不能处理在-之间达到100组的数据"
End
End If

If LStr <> RStr Then GoTo L2
Cells(r, 1) = ""
Cells((r + 1), 1) = ""
Chai = Origin

End Function

操作方法:
先选取要操作的列(或列区域),再运行.

追问

好棒啊！！！
我希望其它列数据不变，复制过去怎么弄。
例如：
列A 列B
1 23,34,35
2 33

拆分后列A的数据：
列A 列B
1 23
1 34
1 35
2 33
...
thank you !

追答

以上代碼是通用型,除逗號分開外,還可以分開帶"-"的數據,比如:1.5-1.9可以分開為:1.5,1.6,1.7,1.8,1.9
建議你用Excel公式.
1. 在序號與數據之間插入一例.
2. 使用公式:=if(左邊單元格="",上面單元格,左邊單元格) ----如果沒有"上面單元格"(可能在B1),請將第一個數據Copy過來,從第二個開始.
3. 公式往下拉就OK了

追问

嗯，这个方法可以实现我最初的想法了~谢谢~

我的表格目前有20多列，这样的话，如果每列记录都插入新的一列，这样就有40多列了。
还能有简单的方法吗？

Answer 4

这种事情也要找VBA？？？

追问

您有简单的方法？