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经典代码实践指南
查看: 283|回复: 7

[求助] 帮助写一个自定义排序函数用VBA写

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-28 10:02 | 显示全部楼层 |阅读模式
                        写一个自定义函数,以B3:K3中的值的大小应对0~9数字进行排序,并连带起来
  被排序的数据  0  1  2  3  4  5  6  7  8  9  结果  
    1.2  1.5  0.7  3.4  1.1  0.6  2  2.2  1.3  1  3761804925  
    50  76  10  51  22  14  80  21  22  34  6130948752  
                          
                          
写一个VBA自定义排序函数.png
写一个VBA自定义排序函数.png

TA的精华主题

TA的得分主题

发表于 2020-1-28 10:10 | 显示全部楼层
连个附件都懒得上传,还得帮你做个附件????

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-28 10:24 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-28 10:32 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-28 10:44 | 显示全部楼层
点击按钮实现效果
Sub test()
Set d = CreateObject("scripting.dictionary")
With Sheet1
    ws = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("a2:l" & ws)
    For i = 2 To UBound(ar)
        k = ""
        n = 0
        ReDim br(1 To UBound(ar))
        For jj = 1 To 10
            For j = 2 To UBound(ar, 2) - 1
                m = Application.Large(Application.Index(ar, i, 0), jj)
                If ar(i, j) = m Then
                    n = n + 1
                    d(ar(1, j)) = ""
                End If
            Next j
        Next jj
        For Each ss In d.keys
            If k = "" Then
                 k = ss
            Else
               k = k & ss
            End If
        Next ss
        ar(i, 12) = k
        d.RemoveAll
    Next i
    .Range("a2:l" & ws) = ar
End With
End Sub

TA的精华主题

TA的得分主题

发表于 2020-1-28 10:46 | 显示全部楼层
Book1.zip (13.88 KB, 下载次数: 4)

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-28 10:56 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-28 11:58 | 显示全部楼层
Option Explicit

Sub test()
  Dim arr, brr, i As Long, j As Long, k As Long, t As String
  arr = [b2:k2].Value
  ReDim mark(1 To UBound(arr, 2)) As String
  For i = 1 To UBound(mark)
    mark(i) = arr(1, i)
  Next
  arr = Range("b3:k" & Cells(Rows.Count, "b").End(xlUp).Row).Value
  For i = 1 To UBound(arr, 1)
    brr = mark
    For j = 1 To UBound(arr, 2) - 1
      For k = 1 To UBound(arr, 2) - j
        If Val(arr(i, k)) < Val(arr(i, k + 1)) Then
          t = arr(i, k): arr(i, k) = arr(i, k + 1): arr(i, k + 1) = t
          t = brr(k): brr(k) = brr(k + 1): brr(k + 1) = t
        End If
      Next
    Next
    For j = 2 To UBound(brr)
      brr(1) = brr(1) & brr(j)
    Next
    arr(i, 1) = brr(1)
  Next
  [l3].Resize(UBound(arr, 1)) = arr
End Sub

评分

参与人数 2鲜花 +5 收起 理由
LSYYLW + 2 太强大了
YZC51 + 3 太强大了

查看全部评分

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

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2020-5-30 21:04 , Processed in 0.092308 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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