[已解决]放资料

fangniuji

帮忙一下，H2是作用对象，G2以下是如G1描述（放序号下面数据）I2以下如G2以下描述（放H2序号后面数据）H2前面G2或后面I2，G2和I2同时有数据就同时执行，数据源A列结果如B列，如果I2以下没数据时，结果如F列，如果G2以下没数据，结果如J列.G 2和I2 以下不一定有几个数据，谢谢。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-19 21:59

1. Option Explicit
   
2. Sub 放资料()
   
3.     '2012-12-19 hwc2ycy 修改
   
4.     Dim str2$, pos2&
   
5.     Dim rg1 As Range    '序号下面的数据
   
6.     Dim rg3 As Range, pos3&   '放在序号后面的数据
   
7.    
   
8.     Dim i&, i3&
   
9.         
   
10.     str2 = UCase(Range("h2"))
    
11.    
    
12.     On Error Resume Next
    
13.     ' 数据的局限性，必须以非数字开始，其后必须是数字
    
14.     If Len(str2) = 0 Then MsgBox "H2单元格无数据": Exit Sub
    
15.     If Len(str2) > 2 Then str2 = Left(str2, 1) & Right(str2, Len(str2) - 1) * 1
    
16.    
    
17.     i = Cells(Rows.Count, "g").End(xlUp).Row
    
18.     If i >= 2 Then Set rg1 = Range("g2:g" & i)
    
19.     i = Cells(Rows.Count, "i").End(xlUp).Row
    
20.     If i >= 2 Then Set rg3 = Range("i2:i" & i)
    
21.    
    
22.     '放序号下面的数据
    
23.     If Not rg1 Is Nothing Then
    
24.         pos2 = Range("a:a").Find(str2, , , xlWhole).Row
    
25.         If Err.Number <> 0 Then MsgBox "H2数据无法找到": Exit Sub
    
26.         Application.ScreenUpdating = False
    
27.         rg1.Copy
    
28.         Range("a" & pos2 + 1).Insert xlShiftDown
    
29.         Application.CutCopyMode = False
    
30.         pos3 = pos2 + 1 + rg1.Count
    
31.         Application.ScreenUpdating = True
    
32.     End If
    
33.    
    
34.     '放序号后面数据
    
35.     If Not rg3 Is Nothing Then
    
36.         If pos3 = 0 Then
    
37.             pos2 = Range("a:a").Find(str2, , , xlWhole).Row
    
38.             If Err.Number <> 0 Then MsgBox "H2数据无法找到": Exit Sub
    
39.             i = pos2 + 1
    
40.         Else
    
41.             i = pos3
    
42.         End If
    
43.         Do Until Cells(i, 1) Like "T??" Or Cells(i, 1) Like "T?" Or Len(Cells(i, 1)) = 0 Or Cells(i, 1) Like "%" Or Cells(i, 1) Like "M30"
    
44.             i = i + 1
    
45.         Loop
    
46.         
    
47.         pos3 = i
    
48.         Application.ScreenUpdating = False
    
49.         rg3.Copy
    
50.         Range("a" & pos3).Insert xlShiftDown
    
51.         Application.CutCopyMode = False
    
52.         Application.ScreenUpdating = True
    
53.     End If
    
54. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Option Explicit
   
2. Sub 放资料()
   
3.     '2012-12-19 hwc2ycy 修改
   
4.     Dim str2$, pos2&
   
5.     Dim rg1 As Range    '序号下面的数据
   
6.     Dim rg3 As Range, pos3&   '放在序号后面的数据
   
7.    
   
8.     Dim i&, i3&
   
9.         
   
10.     str2 = UCase(Range("h2"))
    
11.    
    
12.     On Error Resume Next
    
13.     ' 数据的局限性，必须以非数字开始，其后必须是数字
    
14.     If Len(str2) = 0 Then MsgBox "H2单元格无数据": Exit Sub
    
15.     If Len(str2) > 2 Then str2 = Left(str2, 1) & Right(str2, Len(str2) - 1) * 1
    
16.    
    
17.     i = Cells(Rows.Count, "g").End(xlUp).Row
    
18.     If i >= 2 Then Set rg1 = Range("g2:g" & i)
    
19.     i = Cells(Rows.Count, "i").End(xlUp).Row
    
20.     If i >= 2 Then Set rg3 = Range("i2:i" & i)
    
21.    
    
22.     '放序号下面的数据
    
23.     If Not rg1 Is Nothing Then
    
24.         pos2 = Range("a:a").Find(str2, , , xlWhole).Row
    
25.         If Err.Number <> 0 Then MsgBox "H2数据无法找到": Exit Sub
    
26.         Application.ScreenUpdating = False
    
27.         rg1.Copy
    
28.         Range("a" & pos2 + 1).Insert xlShiftDown
    
29.         Application.CutCopyMode = False
    
30.         pos3 = pos2 + 1 + rg1.Count
    
31.         Application.ScreenUpdating = True
    
32.     End If
    
33.    
    
34.     '放序号后面数据
    
35.     If Not rg3 Is Nothing Then
    
36.         If pos3 = 0 Then
    
37.             pos2 = Range("a:a").Find(str2, , , xlWhole).Row
    
38.             If Err.Number <> 0 Then MsgBox "H2数据无法找到": Exit Sub
    
39.             i = pos2 + 1
    
40.         Else
    
41.             i = pos3
    
42.         End If
    
43.         Do Until Cells(i, 1) Like "T??" Or Cells(i, 1) Like "T?" Or Len(Cells(i, 1)) = 0 Or Cells(i, 1) Like "%" Or Cells(i, 1) Like "M30"
    
44.             i = i + 1
    
45.         Loop
    
46.         
    
47.         pos3 = i
    
48.         Application.ScreenUpdating = False
    
49.         rg3.Copy
    
50.         Range("a" & pos3).Insert xlShiftDown
    
51.         Application.CutCopyMode = False
    
52.         Application.ScreenUpdating = True
    
53.     End If
    
54. End Sub

复制代码

hwc2ycy

效果图貌似不对。

hwc2ycy

要插入的数据不要用M30或T之类的数据，不然用别的代码在这里，容易出错的。