[已解决]如何按价格升序排列

759857387

Book12.rar (24.63 KB, 下载次数: 26)

2014-6-15 09:15 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-6-15 11:26

759857387 发表于 2014-6-15 11:13
结果是这样
黑框的数据没有到最下面；能否加入其它列；能否不提示就在原地

1. Sub test()
   
2.   Dim arr, i&, t&, tmp(1), rng As Range
   
3.   Application.EnableEvents = False
   
4.   On Error Resume Next
   
5.   Set rng = Application.InputBox("请选择需要排序的区域", "提示", "$B$6:$B$25", , , , , 8)
   
6.   If Err.Number > 0 Then MsgBox "请选择一个有效的数据区域": Exit Sub
   
7.   For j = 1 To rng.Columns.Count
   
8.   arr = rng.Columns(j).Value
   
9.      For i = 1 To UBound(arr) Step 2
   
10.          For t = i + 2 To UBound(arr) Step 2
    
11.              If Val(arr(t, 1)) > Val(arr(i, 1)) Then
    
12.                 tmp(0) = arr(i, 1)
    
13.                 tmp(1) = arr(i + 1, 1)
    
14.                 arr(i, 1) = arr(t, 1)
    
15.                 arr(i + 1, 1) = arr(t + 1, 1)
    
16.                 arr(t, 1) = tmp(0)
    
17.                 arr(t + 1, 1) = tmp(1)
    
18.              End If
    
19.          Next
    
20.      Next
    
21.   rng.Columns(j) = arr
    
22.   Next
    
23.   Application.EnableEvents = True
    
24. End Sub

复制代码

刚才漏写个step2 哈哈

跳转到最佳答案楼层

baksy

可以模拟一下结果吗？

759857387

baksy 发表于 2014-6-15 10:13
可以模拟一下结果吗？

baksy

759857387 发表于 2014-6-15 10:23

哪个是数据源？哪个是结果？

759857387

baksy 发表于 2014-6-15 10:27
哪个是数据源？哪个是结果？

1楼是数据源，3楼是结果。

tgydslr

把附件传上来吧，自己造数据还怪麻烦的
既然求助，就要为解答人多想想

759857387

tgydslr 发表于 2014-6-15 10:38
把附件传上来吧，自己造数据还怪麻烦的
既然求助，就要为解答人多想想

附件已经在1楼啦

baksy

759857387 发表于 2014-6-15 10:32
1楼是数据源，3楼是结果。

G6公式，三键回车，横拉、下拉。
=IF(MOD(ROW(),2)=0,LARGE(IF(--B$6:B$25<99,--B$6:B$25),INT((ROW()-6)/2)+1),OFFSET(B$5,MATCH(G5,--B$6:B$25,0)+1,))

xdragon

1. Sub test()
   
2.   Dim arr, i&, j%, t&, tmp(1)
   
3.   Application.EnableEvents = False
   
4.   On Error Resume Next
   
5.   arr = Application.InputBox("请选择需要排序的区域", "提示", "$B$6:$B$25", , , , , 8).Value
   
6.   If Err.Number > 0 Then MsgBox "请选择一个有效的数据区域": Exit Sub
   
7.      For i = 1 To UBound(arr) Step 2
   
8.          For t = i + 2 To UBound(arr)
   
9.              If arr(t, 1) > arr(i, 1) Then
   
10.                 tmp(0) = arr(i, 1)
    
11.                 tmp(1) = arr(i + 1, 1)
    
12.                 arr(i, 1) = arr(t, 1)
    
13.                 arr(i + 1, 1) = arr(t + 1, 1)
    
14.                 arr(t, 1) = tmp(0)
    
15.                 arr(t + 1, 1) = tmp(1)
    
16.              End If
    
17.          Next
    
18.      Next
    
19.   Application.InputBox("请选择排序后导出区域", "提示", "$G$6", , , , , 8).Resize(UBound(arr)) = arr
    
20.   If Err.Number > 0 Then MsgBox "请选择一个有效的数据区域": Exit Sub
    
21.   Application.EnableEvents = True
    
22. End Sub

复制代码

759857387

xdragon 发表于 2014-6-15 10:58

结果是这样
黑框的数据没有到最下面；能否加入其它列；能否不提示就在原地