Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then Exit Sub
Dim i
Dim c
If InStr(Cells(Target.Row + 1, Target.Column), " ") > 0 Then
Cells(Target.Row + 1, Target.Column).Select
End If
If InStr(Cells(Target.Row, Target.Column), " ") > 0 Then
i = Target.Row
'MsgBox "当前行" & i
c = Cells(i, 1)
'MsgBox "单元格值" & c
Rows(i + 1 & ":" & i + 1).Select
'MsgBox "选择" & i + 1 & "整行"
Selection.Insert shift:=xlDown
'MsgBox "插入行"
Selection.FillDown
'MsgBox "向下填充"
Cells(i, 1) = Left(c, InStr(c, " ") - 1)
'MsgBox "单元格" & Cells(i, 1).Address & "值:" & Left(c, InStr(c, " ") - 1)
Cells(i + 1, 1) = Right(c, Len(c) - InStr(c, " "))
'MsgBox "单元格" & Cells(i + 1, 1).Address & "值:" & Right(c, Len(c) - InStr(c, " "))
Rows(i + 1 & ":" & i + 1).Select
'MsgBox "选择行" & i + 1
End If
End Sub
如果单元格内有两个或两个以上" "(空格) 就出错示例数据
HS074057
HS074056-2
HS50261-1-E HS50261-2-E HS50261-3-E
HS50262-1-D HS50262-2-D HS50262-3-D
HS50262-1-E HS50262-2-E HS50262-3-E
HS50261-1-D HS50261-2-D HS50261-3-D
HSS074070 HS074053
HS074063-1 HS074063-2
HS074064-1 HS074064-2
HS074069-1 HS074069-2
HS074067-1 HS074067-2
HS074061-1 HS074061-2
HS074060-1 HS074060-2
HS074054
HS074065 HS074066-1 HS074066-2
HS074051 HS074052
HS074068 HS074062
===============================================================
RC Models
你的程序中有很多select。每select一次都要调用一次本事件。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then Exit Sub
Dim a As Variant
Dim i As Integer, n As Integer
If InStr(Target.Offset(1, 0), " ") > 0 Then
Target.Offset(1, 0).Select
End If
If InStr(Target, " ") > 0 Then
a = Split(Target, " ")
n = UBound(a)
Target = a(0)
For i = 1 To n
Rows(Target.Row + i).Insert shift:=xlDown
Target.Offset(i, 0) = a(i)
Next
End If
End Sub
RC Models