[已解决]D列中的数字是几，就在下面增加（几-1）个空白行？

小雨饰品

D列中的数字是几，就在下面增加（几-1）个空白行（效果达到 SHEET1式样）。比如说：D3中数字是3，就在下面增加2个空白行（即3-1），D5数字是1，就增加0行（实际就是不增加，即1-1）；D6O中数字为4，就增加3个空白行（妈3-1），以此类推。谢谢

最佳答案

月排行榜 / 总排行榜

zjcat35

2012-5-21 10:39

1. 
   
2. 
   
3. Sub 插入空行()
   
4.     Dim arr, i As Integer, j As Integer
   
5.     Application.ScreenUpdating = False
   
6.     i = Cells(Rows.Count, 4).End(3).Row
   
7.     arr = Range("d4:d" & i)
   
8.     For j = i To 5 Step -1
   
9. if arr(j-4,1) <> 1 then
   
10.         Rows(j).Resize(arr(j - 4, 1)-1).Insert
    
11. end if
    
12.     Next j
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

跳转到最佳答案楼层

zjcat35

1. 
   
2. 
   
3. Sub 插入空行()
   
4.     Dim arr, i As Integer, j As Integer
   
5.     Application.ScreenUpdating = False
   
6.     i = Cells(Rows.Count, 4).End(3).Row
   
7.     arr = Range("d4:d" & i)
   
8.     For j = i To 5 Step -1
   
9. if arr(j-4,1) <> 1 then
   
10.         Rows(j).Resize(arr(j - 4, 1)-1).Insert
    
11. end if
    
12.     Next j
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

砂海

{:02:} 增加,减少 行列 用倒循环.

ws278106483

1. 
   

复制代码

ws278106483

1. Sub 插入空行()
   
2.     Dim arr, i As Integer, j As Integer
   
3.     Application.ScreenUpdating = False
   
4.     i = Cells(Rows.Count, 4).End(3).Row
   
5.     arr = Range("d4:d" & i)
   
6.     For j = i To 5 Step -1
   
7. If arr(j - 4, 1) <> 1 Then
   
8.         Rows(j).Resize(arr(j - 4, 1) - 1).Insert
   
9. End If
   
10.     Next j
    
11.     Application.ScreenUpdating = True
    
12. Call tianc
    
13. Call heb
    
14. End Sub
    
15. Sub heb()
    
16.   Dim y, mrg1 As Range
    
17.     Application.DisplayAlerts = False
    
18.      Set mrg1 = [d4]
    
19.       For y = 2 To Range("d65536").End(xlUp).Row + 1
    
20.         If Cells(y, 4) = Cells(y - 1, 4) Then
    
21.           Set mrg = Union(mrg, Cells(y, 4))
    
22.         Else
    
23.           mrg1.Merge
    
24.           Set mrg1 = Cells(y, 4)
    
25.         End If
    
26.      Next y
    
27.     Application.DisplayAlerts = True
    
28.    
    
29. End Sub
    
30. Sub tianc()
    
31.   Dim x As Integer
    
32.   Dim mrg As Range
    
33.      Set mrg = [d4]
    
34.     For x = 2 To Range("d65536").End(xlUp).Row - 1
    
35.        If Cells(x + 1, 4) = "" Then
    
36.          Set mrg = Cells(x, 4)
    
37.         Cells(x + 1, 4) = mrg
    
38.         
    
39.         Else
    
40.         
    
41.         Set mrg = Cells(x, 4)
    
42.        End If
    
43.     Next x
    
44.    
    
45. End Sub
    
46. 
    

复制代码

ws278106483

Sub 插入空行()
    Dim arr, i As Integer, j As Integer
    Application.ScreenUpdating = False
    i = Cells(Rows.Count, 4).End(3).Row
    arr = Range("d4:d" & i)
    For j = i To 5 Step -1
If arr(j - 4, 1) <> 1 Then
        Rows(j).Resize(arr(j - 4, 1) - 1).Insert
End If
    Next j
    Application.ScreenUpdating = True
Call tianc
Call heb
End Sub
Sub heb()
  Dim y, mrg1 As Range
    Application.DisplayAlerts = False
     Set mrg1 = [d4]
      For y = 2 To Range("d65536").End(xlUp).Row + 1
        If Cells(y, 4) = Cells(y - 1, 4) Then
          Set mrg1 = Union(mrg1, Cells(y, 4))
        Else
          mrg1.Merge
          Set mrg1 = Cells(y, 4)
        End If
     Next y
    Application.DisplayAlerts = True
   
End Sub
Sub tianc()
  Dim x As Integer
  Dim mrg As Range
     Set mrg = [d4]
    For x = 2 To Range("d65536").End(xlUp).Row - 1
       If Cells(x + 1, 4) = "" Then
         Set mrg = Cells(x, 4)
        Cells(x + 1, 4) = mrg
        
        Else
        
        Set mrg = Cells(x, 4)
       End If
    Next x
   
End Sub

ws278106483

运行，插入行。

ws278106483

附件跟上，楼主看一下

ws278106483

Sub 插入空行()
    Dim arr, i As Integer, j As Integer
    Application.ScreenUpdating = False
    i = Cells(Rows.Count, 4).End(3).Row
    arr = Range("d4:d" & i)
    For j = i To 5 Step -1
If arr(j - 4, 1) <> 1 Then
        Rows(j).Resize(arr(j - 4, 1) - 1).Insert
End If
    Next j
    Application.ScreenUpdating = True
Call tianc
Call heb
End Sub
Sub heb()
  Dim y, mrg1 As Range
    Application.DisplayAlerts = False
     Set mrg1 = [d4]
      For y = 2 To Range("d65536").End(xlUp).Row + 1
        If Cells(y, 4) = Cells(y - 1, 4) Then
          Set mrg1 = Union(mrg1, Cells(y, 4))
        Else
          mrg1.Merge
          Set mrg1 = Cells(y, 4)
        End If
     Next y
    Application.DisplayAlerts = True
   
End Sub
Sub tianc()
  Dim x As Integer
  Dim mrg As Range
     Set mrg = [d4]
    For x = 2 To Range("d65536").End(xlUp).Row - 1
       If Cells(x + 1, 4) = "" Then
         Set mrg = Cells(x, 4)
        Cells(x + 1, 4) = mrg
        
        Else
        
        Set mrg = Cells(x, 4)
       End If
    Next x
   
End Sub

小雨饰品

zjcat35 发表于 2012-5-21 10:39

感谢大师的帮助。
谢谢谢谢