Excel表格中，有高分加哦。如果您是VBA高手，并有足够的耐心，和丰富的知识，请帮助我提高代码的运行速度

Public Sub iSub()
Dim R&, r0&, c%, c0%, c1%
r0 = 2 '开始的行位置
c0 = Range("Q1").Column '需要被复制的列位置设置在Q列
c1 = Range("AI1").Column '粘贴的列位置，最初设置在AI列
Application.ScreenUpdating = False '关闭屏幕刷新
Application.Calculation = xlManual '手动计算
For R = r0 To Cells(65536, c0).End(xlUp).Row
c = Cells(R, 60).End(xlToLeft).Column '60表示从左边开始到可以最多粘贴到第60-1列，本代码先检查第60列有无数据，没有往前检测，直到有数据，停止,该数据可以根据需要修改成需要的数据
If c < c1 Then c = c1 Else c = c + 1 'c+2表示每隔2行粘贴，如果是c+1表示每隔一行开始粘贴
Cells(R, c).Value = Cells(R, c0).Value
Cells(R, c0).Resize(1, 2).ClearContents '这代码的意思是删除被复制列，和他后面的一列本例是Q列和他后面的R列。
Next
Application.ScreenUpdating = True '打开屏幕刷新
Application.Calculation = xlAutomatic '自动重算
End Sub

Private Sub CommandButton1_Click()
Sheet1.iSub '指定按钮
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim R2&
If Target.Row > 1 And Target.Column = 7 And Target.Count = 1 Then
R2 = Target.Row
If Target.Value > 0 Then
If Cells(R2, 1) = "" Then
Cells(R2, 1) = Cells(R2 - 1, 1)
End If
If Cells(R2, 4) = "" Then
Cells(R2, 4) = Cells(R2 - 1, 4)
End If
If Cells(R2, 5) = "" Then
Cells(R2, 5) = Cells(R2 - 1, 5)
End If
End If
End If

If Target.Row = 1 Or Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
Select Case Target.Column
Case Is = 7
If Target.Value > 0 Then
With Target.Offset(0, -4)
If .Value > 0 Then
Else
If Target.Offset(0, -6) = Target.Offset(-1, -6) Then .Value = Target.Offset(-1, -4).Value
End If
If .Value > 0 Then
Else
.Value = Now
.NumberFormatLocal = "yyyy-m-d h:mm;@"
End If
End With
End If
End Select

If Target.Row = 1 Then Exit Sub '加入本句可让代码从第2行开始运行
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 = 75 '固定从第75列开始输出(BW列)，=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 '本段是将D列的铜管规格数据分列到BW列、BX列By列

Dim R3&
If Target.Row > 1 And Target.Column = 18 Then '18表示在第18列也就是I列任意输入数据
R3 = Target.Row
If Cells(R3, 16) > 0 Then '检查第16列的是否大于0，然后复制
Cells(R3, 17) = Cells(R3, 16) 'Cells(R3, 17) 表示H列 同样cells（R3,7）表示G列
End If
End If

If Target.Row = 1 Or Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
Select Case Target.Column
Case Is = 35, 37, 39, 41, 43, 45, 47, 49, 51, 53, 55, 57, 59
If Target.Value > 0 Then
With Target.Offset(0, 1)
.Value = Now
.NumberFormatLocal = "m-d "
End With
End If
End Select
Application.EnableEvents = True

End Sub