[已解决]复制问题再重新排序

fangniuji

第一：数据源在A列，根据E列选择“√”在数据源“%”上复制。结果如G列G13。
第二：E列选择在%以下对应坐标在“M30”之上复制，结果如G44到G46。
第三：重新递增排序如H列（如H13，H44）
最后：把结果放A列。E 列没有“√”，提示没有资料处理。帮忙写个代码，谢谢！！！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-22 18:05

1. Sub 数据处理()
   
2.     'On Error Resume Next
   
3.    
   
4.     Dim rgChoose As Range
   
5.     Dim rgPer As Range
   
6.     Dim rgFin As Range
   
7.     Dim str$
   
8.     Dim i&
   
9.     Dim Address$
   
10.    
    
11.     Application.ScreenUpdating = False
    
12. 
    
13.     Set rgChoose = Range("e:e").Find(what:="√", lookat:=xlWhole)
    
14.    
    
15.     If rgChoose Is Nothing Then
    
16.         MsgBox "没有资料处理"
    
17.         Exit Sub
    
18.     End If
    
19.    
    
20.     Set rgPer = Range("a:a").Find(what:="%", lookat:=xlWhole)
    
21.     If rgPer Is Nothing Then MsgBox "A列无%": Exit Sub
    
22.    
    
23.     Cells(rgChoose.Row, 1).Copy
    
24.     rgPer.Insert
    
25.    
    
26.     Application.CutCopyMode = False
    
27.    
    
28.     str = rgPer.Offset(-1)
    
29.     Mid(str, 2, 2) = Val(Mid(rgPer.Offset(-2), 2, 2)) + 1
    
30.     rgPer.Offset(-1) = str
    
31.    
    
32.     str = rgChoose.Offset(, -3)
    
33.     str = Left(str, 1) & Right(str, Len(str) - 1) / 1
    
34. 
    
35.     Set rgChoose = Nothing
    
36.     Set rgChoose = Range("a:a").Find(what:=str, lookat:=xlWhole)
    
37.     If rgChoose Is Nothing Then MsgBox "在A列没有找到" & str: Exit Sub
    
38.    
    
39.     If Range("a:a").Find(what:="M30", lookat:=xlWhole) Is Nothing Then MsgBox "A列无结束标志M30": Exit Sub
    
40.    
    
41.     i = rgChoose.Row + 1
    
42.     Do While Not (Cells(i, 1) Like "T#*" Or Cells(i, 1) Like "M30" Or Len(Cells(i, 1)) = 0)
    
43.         i = i + 1
    
44.     Loop
    
45.     Range(rgChoose, Cells(i - 1, 1)).Copy
    
46.    
    
47.     Set rgFin = Range("a:a").Find(what:="M30", lookat:=xlWhole)
    
48.     Address = rgFin.Address
    
49.     rgFin.Insert
    
50.    
    
51.     Application.CutCopyMode = False
    
52.     str = Left(rgPer.Offset(-1).Value, 3)
    
53.     Range(Address) = str
    
54. 
    
55. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

楼主整得越来越深入了，你的题都快做不出来了，{:412:}

fangniuji

hwc2ycy 发表于 2013-2-21 13:38
楼主整得越来越深入了，你的题都快做不出来了，

呵呵，谢谢啦！！！大师！！！

hwc2ycy

1. Sub 数据处理()
   
2.     'On Error Resume Next
   
3.     Dim rg As Range
   
4.     Dim str$
   
5.     Dim rgper As Range
   
6.     Application.ScreenUpdating = False
   
7.    
   
8.     Set rg = Range("e:e").Find(what:="√", lookat:=xlWhole)
   
9.     If rg Is Nothing Then
   
10.         MsgBox "没有资料处理"
    
11.         Exit Sub
    
12.     End If
    
13.     Set rgper = Range("a:a").Find(what:="%", lookat:=xlWhole)
    
14.     if rgper is nothing then msgbox "A列无%":exit sub
    
15.     Cells(rg.Row, 1).Copy
    
16.     rgper.Insert
    
17.     Application.CutCopyMode = False
    
18.     str = rgper.Offset(-1)
    
19.     Mid(str, 2, 2) = Val(Mid(rgper.Offset(-2), 2, 2)) + 1
    
20.     rgper.Offset(-1) = str
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "处理完成"
    
23. End Sub

复制代码

hwc2ycy

偷了懒，只针对2位数做处理，要是你数据量多了，达到3位数字了，这代码就不灵光了。

fangniuji

hwc2ycy 发表于 2013-2-21 18:20
偷了懒，只针对2位数做处理，要是你数据量多了，达到3位数字了，这代码就不灵光了。

非常非常谢谢你，谢谢！！！第一要求以帮我处理好。谢谢！！第二：E列选择在%以下对应坐标在“M30”之上复制，结果如G44到G46。 第二再帮我一下，谢谢！！！

fangniuji

hwc2ycy 发表于 2013-2-21 18:20
偷了懒，只针对2位数做处理，要是你数据量多了，达到3位数字了，这代码就不灵光了。

没有三位数，不超过100，谢谢！！！

hwc2ycy

1. Sub 数据处理()
   
2.     'On Error Resume Next
   
3.     Dim rg As Range
   
4.     Dim str$
   
5.     Dim rgper As Range
   
6.     Dim i&
   
7.     Application.ScreenUpdating = False
   
8.    
   
9.     Set rg = Range("e:e").Find(what:="√", lookat:=xlWhole)
   
10.     If rg Is Nothing Then
    
11.         MsgBox "没有资料处理"
    
12.         Exit Sub
    
13.     End If
    
14.     Set rgper = Range("a:a").Find(what:="%", lookat:=xlWhole)
    
15.     If rgper Is Nothing Then MsgBox "A列无%": Exit Sub
    
16.     Cells(rg.Row, 1).Copy
    
17.     rgper.Insert
    
18.     Application.CutCopyMode = False
    
19.     str = rgper.Offset(-1)
    
20.     Mid(str, 2, 2) = Val(Mid(rgper.Offset(-2), 2, 2)) + 1
    
21.     rgper.Offset(-1) = str
    
22.     str = rg.Offset(, -3)
    
23.     str = Left(str, 1) & Val(Right(str, Len(str) - 1))
    
24.    
    
25.     Set rg = Nothing
    
26.     Set rg = Range("a:a").Find(what:=str, lookat:=xlWhole)
    
27.     If rg Is Nothing Then MsgBox "在A列没有找到" & str: Exit Sub
    
28.     If Range("a:a").Find(what:="M30", lookat:=xlWhole) Is Nothing Then MsgBox "A列无结束标志M30": Exit Sub
    
29.     i = rg.Row + 1
    
30.     Do While Not (Cells(i, 1) Like "T#*" Or Cells(i, 1) Like "M30") Or Len(Cells(i, 1)) > 0
    
31.         i = i + 1
    
32.     Loop
    
33.     Range(rg, Cells(i - 1, 1)).Copy
    
34.    
    
35.     Range("a:a").Find(what:="M30", lookat:=xlWhole).Insert
    
36.     Application.CutCopyMode = False
    
37.     msgbox "数据处理完成"
    
38. End Sub

复制代码

fangniuji

hwc2ycy 发表于 2013-2-22 09:35

出现 400，再麻烦一下，谢谢！！！

hwc2ycy

1. Sub 数据处理()
   
2.     'On Error Resume Next
   
3.     Dim rg As Range
   
4.     Dim str$
   
5.     Dim rgper As Range
   
6.     Dim i&
   
7.     Application.ScreenUpdating = False
   
8. 
   
9.     Set rg = Range("e:e").Find(what:="√", lookat:=xlWhole)
   
10.     If rg Is Nothing Then
    
11.         MsgBox "没有资料处理"
    
12.         Exit Sub
    
13.     End If
    
14.     Set rgper = Range("a:a").Find(what:="%", lookat:=xlWhole)
    
15.     If rgper Is Nothing Then MsgBox "A列无%": Exit Sub
    
16.     Cells(rg.Row, 1).Copy
    
17.     rgper.Insert
    
18.     Application.CutCopyMode = False
    
19.     str = rgper.Offset(-1)
    
20.     Mid(str, 2, 2) = Val(Mid(rgper.Offset(-2), 2, 2)) + 1
    
21.     rgper.Offset(-1) = str
    
22.     str = rg.Offset(, -3)
    
23.     str = Left(str, 1) & Val(Right(str, Len(str) - 1))
    
24. 
    
25.     Set rg = Nothing
    
26.     Set rg = Range("a:a").Find(what:=str, lookat:=xlWhole)
    
27.     If rg Is Nothing Then MsgBox "在A列没有找到" & str: Exit Sub
    
28.     If Range("a:a").Find(what:="M30", lookat:=xlWhole) Is Nothing Then MsgBox "A列无结束标志M30": Exit Sub
    
29.     i = rg.Row + 1
    
30.     Do While Not (Cells(i, 1) Like "T#*" Or Cells(i, 1) Like "M30" Or Len(Cells(i, 1)) = 0)
    
31.         i = i + 1
    
32.     Loop
    
33.     Range(rg, Cells(i - 1, 1)).Copy
    
34. 
    
35.     Range("a:a").Find(what:="M30", lookat:=xlWhole).Insert
    
36.     Application.CutCopyMode = False
    
37.     msgbox "数据处理完成"
    
38. End Sub

复制代码