[已解决]修改宏代码

LangQueS

以下的两个宏，用于根据A列单元的数值大小分别插入相应数量的行或单元格，现需要修改为根据第n列(或指定列标)单元的数值大小插入行或单元格，请帮助修改代码。谢谢！

Sub 按A列数值在数值各自位置批量插入相应数量的行()
Dim i As Integer
For i = Range("a65536").End(xlUp).Row To 1 Step -1
If VBA.IsNumeric(Cells(i, 1)) And Cells(i, 1) > 0 Then
Application.ScreenUpdating = False       '禁用屏幕刷新
Cells(i, 1).Offset(1, 0).Resize(Cells(i, 1).Value, 1).Select
    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
Application.ScreenUpdating = True         '恢复屏幕刷新
End Sub

Sub 按A列数值在数值各自位置以下批量插入相应数量的单元格()
Dim i As Integer
For i = Range("a65536").End(xlUp).Row To 1 Step -1
If VBA.IsNumeric(Cells(i, 1)) And Cells(i, 1) > 0 Then
Application.ScreenUpdating = False          '禁用屏幕刷新
Cells(i, 1).Offset(1, 0).Resize(Cells(i, 1).Value, 1).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
Application.ScreenUpdating = True       '恢复屏幕刷新
End Sub

[此贴子已经被作者于2007-10-29 8:28:50编辑过]

山菊花

Sub 按当前列数值在数值各自位置批量插入相应数量的行()
Dim i As Integer, j As Integer
If MsgBox("根据" & Selection.Range("a1").EntireColumn.Address(0, 0) & "数值插入行吗？", 36, "插入行") = 7 Then Exit Sub
j = Selection.Column
For i = Cells(65536, j).End(xlUp).Row To 1 Step -1
If IsNumeric(Cells(i, j)) And Cells(i, j) > 0 Then
Application.ScreenUpdating = False       '禁用屏幕刷新
Cells(i, 1).Offset(1).Resize(Cells(i, j), 1).EntireRow.Insert
End If
Next
Application.ScreenUpdating = True         '恢复屏幕刷新
End Sub

LangQueS

2楼山菊花超级版主的代码很好用。非常感谢！

请再看看下一段。

山菊花

Sub 按当前列数值在数值各自位置以下批量插入相应数量的单元格()
Dim i1%, i2%, j%, Target As Range, Rng As Range

If Selection.Columns.Count > 1 Then
MsgBox "不允许选择多列。   ", 48, "警告"
Exit Sub
End If

j = Selection.Column
If Selection.Cells.Count = 1 Then
Set Target = Range(Cells(1, j), Cells(65536, j).End(xlUp))
Else
Set Target = Selection   '允许在一列中选择部分区域进行插入单元格操作
End If

If MsgBox("根据" & Target.Address(0, 0) & "数值插入单元格吗？      ", 36, "插入单元格") = 7 Then Exit Sub

Application.ScreenUpdating = False          '禁用屏幕刷新

i1 = Target.Row
i2 = i1 + Target.Rows.Count - 1

For i = i2 To i1 Step -1
If VBA.IsNumeric(Cells(i, j)) And Cells(i, j) > 0 Then
Cells(i, j).Offset(1, 0).Resize(Cells(i, j).Value, 1).Insert Shift:=xlDown
End If
Next

Application.ScreenUpdating = True       '恢复屏幕刷新
End Sub

LangQueS

感谢山版主的帮助！

问问99

山菊花 发表于 2007-10-13 18:07
Sub 按当前列数值在数值各自位置批量插入相应数量的行()Dim i As Integer, j As IntegerIf MsgBox("根据"  ...

有一个问题，代码插入多了一行。我想要的是连同原行一共是等于比如D列的数值，就是说D列写着是“4”，结果是插入3行，连同原有的一行就等于4.且插入的行是复制原先数据，如何实现代码的修改？在线等，万分谢谢！

问问99

Sub 按当前列数值在数值各自位置批量插入相应数量的行()
Dim i As Integer, j As Integer
If MsgBox("根据" & Selection.Range("a1").EntireColumn.Address(0, 0) & "数值插入行吗？", 36, "插入行") = 7 Then Exit Sub
j = Selection.Column
For i = Cells(65536, j).End(xlUp).Row To 1 Step -1
If IsNumeric(Cells(i, j)) And Cells(i, j) > 0 Then
Application.ScreenUpdating = False       '禁用屏幕刷新
Cells(i, 1).Offset(1).Resize(Cells(i, j), 1).EntireRow.Insert
End If
Next
Application.ScreenUpdating = True         '恢复屏幕刷新
End Sub
求家人帮我修改下这段代码。我的需求，比如，D列数值是5时，插入4行，且复制原来行数据到这4行中，如何实际代码。万分感谢！