ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 238|回复: 3

[求助] 提取特定数字对应的信息

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-14 14:07 | 显示全部楼层 |阅读模式
请教各位大神,怎么从基础数据中提取最大的10个数字对应的物料编码、物料名称、数量信息填充到数据提取表格中,同时提取最小的10个数字对应的物料编码、物料名称、数量信息进行填充。谢谢!

工作簿1.rar

17.75 KB, 下载次数: 8

TA的精华主题

TA的得分主题

发表于 2020-2-14 14:59 | 显示全部楼层
Option Explicit

Sub test()
  Dim arr
  With Sheets("基础数据")
    arr = .Range("a2:c" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  ReDim brr(1 To 10, 1 To 4)
  With Sheets("数据提取")
    Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 3, False)
    Call getdata(arr, brr, UBound(brr, 1))
    .[a3].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 3, True)
    Call getdata(arr, brr, UBound(brr, 1))
    .[e3].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
End Sub

Function getdata(arr, brr, cnt)
  Dim i, j
  For i = 1 To cnt
    brr(i, 1) = i
    For j = 1 To UBound(arr, 2)
      brr(i, j + 1) = arr(i, j)
    Next
    If cnt = UBound(arr, 1) Then Exit Function
  Next
End Function

Function bsort(arr, first, last, left, right, key, order)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) <> arr(j + 1, key) Then
        If arr(j, key) < arr(j + 1, key) Xor order Then
          For k = left To right
            t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
          Next
        End If
      End If
    Next
  Next
End Function

TA的精华主题

TA的得分主题

发表于 2020-2-14 15:28 | 显示全部楼层
本帖最后由 shenjianrong163 于 2020-2-14 15:33 编辑

直接用SQL查询(你的“基础数据”表中C列有很多多余的0要清除掉):
  1. Sub test()
  2.     Dim Conn As Object, Rst As Object, Rst1 As Object
  3.     Dim strConn As String, strSQL, strSQL1, arr, brr
  4.     Dim Pathstr As String
  5.     Pathstr = ThisWorkbook.FullName '文件路径,工作簿名
  6.     Set Conn = CreateObject("ADODB.Connection")
  7.     Set Rst = CreateObject("ADODB.Recordset")
  8.     Select Case Application.Version * 1
  9.         Case Is <= 11
  10.             strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source=" & Pathstr
  11.         Case Is >= 12
  12.             strConn = "provider=Microsoft.ACE.Oledb.12.0;Data Source=" & Pathstr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
  13.     End Select
  14.     Conn.Open strConn
  15.     strSQL = "select top 10 * from(select top 10 * from [" & "基础数据" & "$A1:C]" & " where 移动数量 IS Not Null order by 移动数量 desc)" '降序
  16.     strSQL1 = "select top 10 * from(select top 10 * from [" & "基础数据" & "$A1:C]" & " where 移动数量 IS Not Null order by 移动数量 ASC)" '升序
  17.     Set Rst = Conn.Execute(strSQL)
  18.     arr = Conn.Execute(strSQL).GetRows
  19.     Set Rst = Conn.Execute(strSQL1)
  20.     brr = Conn.Execute(strSQL1).GetRows
  21.     Conn.Close
  22.     Set Conn = Nothing
  23.     Set Rst = Nothing
  24.     With Worksheets("数据提取")
  25.         .Range("B3:D12").ClearContents
  26.         .Range("F3:H12").ClearContents
  27.         .[B3].Resize(UBound(arr, 2) + 1, 3) = Application.Transpose(arr)
  28.         .[F3].Resize(UBound(brr, 2) + 1, 3) = Application.Transpose(brr)
  29.     End With
  30. End Sub
复制代码


TA的精华主题

TA的得分主题

发表于 2020-2-14 15:31 | 显示全部楼层
本帖最后由 shenjianrong163 于 2020-2-14 15:34 编辑

请参考附件:
工作簿1.rar (21.11 KB, 下载次数: 5)
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-9-26 17:42 , Processed in 0.073705 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

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