Excel表格中求数据分列的VBA代码，请将D列的数据分列在I列、J列、K列

Question

D列的数据如图中的四种情况：第1种最常见，两个数据分列在*二边、第2种情况三个数据分列在二个*旁边、第列种情况，只有1个数据，没有*、第4种情况，文字没有*。分列的效果请看图。要求VBA代码可以修改，易懂

Answer 1

我写了一个，测试可行！
它是针对你选中的单元格进行处理，并且支持多选哦（要求所选的单元格在同一列上）。
按楼主的表格，固定从第9列开始输出，当然可以把 x = 9 那一行改改，就其他位置。
代码如下：

Sub 按星号分列()
'以*为分隔符，连续*只算1个。对所选中的单元格进行处理
Dim m As Range, tmpStr As String, s As String, i As Integer
Dim x As Long, y As Long, subStr As String
If Selection.Columns.Count > 1 Then
MsgBox "所选择的数据只能是一列！请重新选择后执行！", vbCritical + vbOKOnly
Exit Sub
End If
If MsgBox("确定要分列处理吗(*为分隔符)？请确定分列的数据会覆盖它后面的单元格！", _
vbYesNoCancel + vbQuestion) <> vbYes Then Exit Sub
For Each m In Selection
x = 9 '固定从第9列开始输出(I列)，=m.Column()就从当前列输出
y = m.Row()
If y > ActiveCell.SpecialCells(xlLastCell).Row() _
Then Exit For '确保所处理的单元格是有效单元格。提高效率
tmpStr = m.Value
subStr = ""
For i = 1 To Len(tmpStr)
s = Mid(tmpStr, i, 1)
If s = "*" Then '*表示子串结束
Cells(y, x).Value = subStr
subStr = ""
x = x + 1
ElseIf s <> "*" Then '新子串开始或进行中
subStr = subStr & s
End If
Next i
If subStr <> "" Then Cells(y, x).Value = subStr
Next m
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

有疑问，请Hi我或给我发百度消息
GoodLuck!

追问

您的代码不错，可以运行。而且基本符合了我的要求，但是，我需要的是一个自动运行的代码，也就是在D列输入数据，在I列、J列、K列自动输入分列的数值，并且分列的数据不允许超过3列。否则我下面一列的数据就被改了

追答

原来楼主需要自动运行的，要早说呀。
我改好了，不但支持手工的单个输入，而且支持整列的复制与删除等批量操作，关键是运行效率还很高。
其实要做到上面这些，还真算是有点高技术，是否可以提高点悬赏分呀？哈哈.....

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tmpStr As String, s As String, i As Integer, m As Range
Dim x As Long, y As Long, subStr As String, num As Integer
On Error GoTo Err
For Each m In Target '因为可能存在批量输入与Copy
y = m.Row()
If y > Range("A1").SpecialCells(xlLastCell).Row() _
Then Exit For '确保所处理的单元格是有效单元格。提高效率
If m.Column() = 4 Then '如果是在D列输入数据的话
Application.EnableEvents = False
num = 0 '计数，确保只拆分最多三个数据
x = 9 '固定从第9列开始输出(I列)，=m.Column()就从当前列输出
Range(Cells(y, x), Cells(y, x + 2)).ClearContents '先清除目标单元格数据
tmpStr = m.Value
subStr = ""
For i = 1 To Len(tmpStr)
s = Mid(tmpStr, i, 1)
If s = "*" Then '*表示子串结束
num = num + 1
Cells(y, x).Value = subStr
subStr = ""
x = x + 1
ElseIf s "*" Then '新子串开始或进行中
subStr = subStr & s
End If
If num = 3 Then Exit For '拆出3个后，不再继续拆
Next i
If subStr "" Then Cells(y, x).Value = subStr
End If
Next m
Err:
Application.EnableEvents = True
End Sub

注：
1、万一出现意外，导致输入数据时不再自动拆分，请完全退出Excel后再重新启动Excel，就会恢复自动了。
2、这段代码所放置的位置不是在模块中，而是在工作表的代码区里。楼主应该懂的 ^-^

有疑问，请Hi我或给我发百度消息
GoodLuck!

Answer 2

Range([d1], [d1].End(xlDown)).TextToColumns Destination:=Range("I1"), OtherChar:="*"