Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3427|回复: 10

[已解决]提取由小到大排列的数据(谢谢老师)

[复制链接]
发表于 2015-2-12 11:52 | 显示全部楼层 |阅读模式
老师:
   我想请教的问题是:提取由小到大排列的数据。
   1、O4:W60000为数据区;
   2、在"生成区"自动提取"数据区"内按由小到大排列的数据。
----------------------------------
   举例说明:
  因为O4<P4<Q4<R4<S4<T4<U4<V4<W4;
  所以此数据保留
   问题.rar (2.7 KB, 下载次数: 13)
发表于 2015-2-12 12:04 | 显示全部楼层
附件

问题.rar

9.35 KB, 下载次数: 7

评分

参与人数 1 +1 收起 理由
kandhong + 1 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2015-2-12 12:51 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, i&
  3. [o4].CurrentRegion.Copy [y4]
  4. arr = [y4].CurrentRegion
  5. For i = 1 To UBound(arr)
  6.     Cells(i + 3, "y").Resize(1, UBound(arr, 2)).Sort Cells(i + 3, "y")
  7. Next
  8. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-2-12 14:04 | 显示全部楼层
dsmch 发表于 2015-2-12 12:51

dsmch老师:
        您提供的vba已收悉,使用的过程中发现有一些出入:
        我的想法是:
        O4:W60000数据区内有一些数据:一些数据按照由小到大顺序排列;一些不是由小到大排列。
        想要实现的效果是:保留由小到大顺序排列的数据
        例如:01 02 03 05 07 08 09 10 11(由小到大排列)这是想要的结果;
                  01 02 03 05 07 08 07 05 09 (不是由小到大排列)这个结果要去掉。

回复

使用道具 举报

发表于 2015-2-12 14:04 | 显示全部楼层
  1. Sub x()
  2. Dim arr, x, y, m, a, brr()
  3. Columns("y:az").Clear
  4. arr = Range("o4").CurrentRegion
  5. ReDim brr(1 To 100000, 1 To UBound(arr, 2))
  6.   For x = 1 To UBound(arr)
  7.    For y = 2 To UBound(arr, 2)
  8.     If arr(x, y) > arr(x, y - 1) Then k = k + 1 Else Exit For
  9.    Next
  10.      If k = 8 Then
  11.       m = m + 1
  12.        For a = 1 To UBound(arr, 2)
  13.         brr(m, a) = arr(x, a)
  14.        Next
  15.      End If
  16.      k = 0
  17.   Next
  18. Range("y4").Resize(m, UBound(arr, 2)) = brr
  19. End Sub
复制代码

问题.rar

16.59 KB, 下载次数: 3

评分

参与人数 1 +3 收起 理由
kandhong + 3 很给力!

查看全部评分

回复

使用道具 举报

发表于 2015-2-12 14:14 | 显示全部楼层
kandhong 发表于 2015-2-12 14:04
dsmch老师:
        您提供的vba已收悉,使用的过程中发现有一些出入:
        我的想法是:
  1. Sub Macro1()
  2. Dim arr, brr, i&, j%, k%, s2&
  3. arr = Range("o4").CurrentRegion
  4. n = UBound(arr, 2)
  5. ReDim brr(1 To UBound(arr), 1 To n)
  6. For i = 1 To UBound(arr)
  7.     s = 0
  8.     For j = 2 To n
  9.         If arr(i, j) > arr(i, j - 1) Then s = s + 1 Else Exit For
  10.     Next
  11.     If s = n - 1 Then
  12.         s2 = s2 + 1
  13.         For k = 1 To n
  14.             brr(s2, k) = arr(i, k)
  15.         Next
  16.     End If
  17. Next
  18. If s2 > 0 Then Range("y4").Resize(s2, n) = brr
  19. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-2-12 16:06 | 显示全部楼层
dsmch 发表于 2015-2-12 14:14

dsmch老师:
       您的VBA已收悉,效果不错。但在使用的过程中发现一个不足:当O4:W60000数据区有大量数据时,VBA失效了。
       请老师抽空看一下!!
         问题.rar (541.49 KB, 下载次数: 5)
回复

使用道具 举报

发表于 2015-2-12 16:24 | 显示全部楼层    本楼为最佳答案   
Sub Macro1()
Dim arr, brr, i&, j%, k%, s2&
arr = Range("o4").CurrentRegion
n = UBound(arr, 2)
ReDim brr(1 To UBound(arr), 1 To n)
For i = 1 To UBound(arr)
    s = 0
    For j = 2 To n
        If arr(i, j) >= arr(i, j - 1) Then s = s + 1 Else Exit For
    Next
    If s = n - 1 Then
        s2 = s2 + 1
        For k = 1 To n
            brr(s2, k) = arr(i, k)
        Next
    End If
Next
If s2 > 0 Then
    Range("y4").Resize(s2, n) = brr
    [Y:AG].NumberFormatLocal = "@"
End If
End Sub

评分

参与人数 1 +3 收起 理由
kandhong + 3 很给力!

查看全部评分

回复

使用道具 举报

发表于 2015-2-12 16:51 | 显示全部楼层
  1. Sub Macro1()
  2.     Dim arr, i&, j%
  3.     Dim DelRng As Range
  4.     arr = Range("o4").CurrentRegion: n = UBound(arr, 2)
  5.     Range("o4").CurrentRegion.Copy [y5]
  6.     Set DelRng = [y1].Resize(1, n)
  7.     For i = 1 To UBound(arr)
  8.         For j = 2 To n
  9.             If arr(i, j) < arr(i, j - 1) Then Set DelRng = Union(DelRng, Cells(i + 4, "y").Resize(1, n)): Exit For
  10.         Next
  11.     Next
  12.     DelRng.Delete shift:=xlShiftUp
  13. End Sub
复制代码

评分

参与人数 2 +7 收起 理由
武林长风 + 6 赞一个!
kandhong + 1 赞一个!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-2-12 17:12 | 显示全部楼层
dsmch 发表于 2015-2-12 16:24
Sub Macro1()
Dim arr, brr, i&, j%, k%, s2&
arr = Range("o4").CurrentRegion

dsmch老师:
         您的VBA是正解,完美之至!!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 17:40 , Processed in 0.571785 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表