设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 如何根据标准列顺序对原始列重新排序三种顺序
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
返回列表 发新帖
查看: 68|回复: 4

[求助] 如何根据标准列顺序对原始列重新排序三种顺序

[复制链接]
yzyyyyyyy

TA的精华主题

TA的得分主题
发表于 2024-12-24 09:55 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
已知一列姓名，顺序固定，作为标准姓名列（可不考虑姓名间有空白）

原始列（示例中有两列，实际中有多列），考虑列姓名间有空白
目标1，对原始列随机排序，有空白单元格保持为空白
目标2，对原始列按标准姓名列正序排列，有空白单元格保持为空白
目标2，对原始列按标准姓名列倒序排列，有空白单元格保持为空白 如何根据标准列顺序对原始列重新排序三种顺序.rar (2.61 KB, 下载次数: 7)
回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2024-12-24 14:38 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
  1. Sub test1() '随机顺序
  2.     Dim r%, i%
  3.     Dim arr, brr
  4.     Randomize Timer
  5.     With Worksheets("sheet1")
  6.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
  7.         arr = .Range("a4:a" & r)
  8.         For j = 4 To 5
  9.             r = .Cells(.Rows.Count, j).End(xlUp).Row
  10.             arr = .Cells(4, j).Resize(r - 3, 1)
  11.             For i = 1 To UBound(arr) - 1
  12.                 If Len(arr(i, 1)) <> 0 Then
  13.                     Do
  14.                         m = Int(Rnd() * (UBound(arr) - i)) + i + 1
  15.                     Loop Until Len(arr(m, 1)) <> 0
  16.                     temp = arr(i, 1)
  17.                     arr(i, 1) = arr(m, 1)
  18.                     arr(m, 1) = temp
  19.                 End If
  20.             Next
  21.             .Cells(4, j).Resize(r - 3, 1) = arr
  22.         Next
  23.     End With
  24. End Sub
复制代码

评分

1

查看全部评分

回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2024-12-24 14:39 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
  1. Sub test2()  '正序
  2.     Dim r%, i%
  3.     Dim arr, brr
  4.     Dim d As Object
  5.     Set d = CreateObject("scripting.dictionary")
  6.     With Worksheets("sheet1")
  7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
  8.         arr = .Range("a4:a" & r)
  9.         For i = 1 To UBound(arr)
  10.             d(arr(i, 1)) = i
  11.         Next
  12.         For j = 4 To 5
  13.             r = .Cells(.Rows.Count, j).End(xlUp).Row
  14.             arr = .Cells(4, j).Resize(r - 3, 1)
  15.             ReDim brr(1 To UBound(arr), 1 To 1)
  16.             For i = 1 To UBound(arr)
  17.                 If Len(arr(i, 1)) <> 0 Then
  18.                     If d.exists(arr(i, 1)) Then
  19.                         brr(i, 1) = d(arr(i, 1))
  20.                     Else
  21.                         brr(i, 1) = 10 ^ 4
  22.                     End If
  23.                 End If
  24.             Next
  25.             For i = 1 To UBound(arr) - 1
  26.                 If Len(arr(i, 1)) <> 0 Then
  27.                     p = i
  28.                     For k = i + 1 To UBound(arr)
  29.                         If Len(arr(k, 1)) <> 0 Then
  30.                             If brr(p, 1) > brr(k, 1) Then
  31.                                 p = k
  32.                             End If
  33.                         End If
  34.                     Next
  35.                     If p <> i Then
  36.                         temp = arr(i, 1)
  37.                         arr(i, 1) = arr(p, 1)
  38.                         arr(p, 1) = temp
  39.                         temp = brr(i, 1)
  40.                         brr(i, 1) = brr(p, 1)
  41.                         brr(p, 1) = temp
  42.                     End If
  43.                 End If
  44.             Next
  45.             .Cells(4, 3 + j).Resize(r - 3, 1) = arr
  46.         Next
  47.     End With
  48. End Sub
复制代码

评分

1

查看全部评分

回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2024-12-24 14:40 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
  1. Sub test3() '倒序
  2.     Dim r%, i%
  3.     Dim arr, brr
  4.     Dim d As Object
  5.     Set d = CreateObject("scripting.dictionary")
  6.     With Worksheets("sheet1")
  7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
  8.         arr = .Range("a4:a" & r)
  9.         For i = 1 To UBound(arr)
  10.             d(arr(i, 1)) = i
  11.         Next
  12.         For j = 4 To 5
  13.             r = .Cells(.Rows.Count, j).End(xlUp).Row
  14.             arr = .Cells(4, j).Resize(r - 3, 1)
  15.             ReDim brr(1 To UBound(arr), 1 To 1)
  16.             For i = 1 To UBound(arr)
  17.                 If Len(arr(i, 1)) <> 0 Then
  18.                     If d.exists(arr(i, 1)) Then
  19.                         brr(i, 1) = d(arr(i, 1))
  20.                     Else
  21.                         brr(i, 1) = 10 ^ 4
  22.                     End If
  23.                 End If
  24.             Next
  25.             For i = 1 To UBound(arr) - 1
  26.                 If Len(arr(i, 1)) <> 0 Then
  27.                     p = i
  28.                     For k = i + 1 To UBound(arr)
  29.                         If Len(arr(k, 1)) <> 0 Then
  30.                             If brr(p, 1) < brr(k, 1) Then
  31.                                 p = k
  32.                             End If
  33.                         End If
  34.                     Next
  35.                     If p <> i Then
  36.                         temp = arr(i, 1)
  37.                         arr(i, 1) = arr(p, 1)
  38.                         arr(p, 1) = temp
  39.                         temp = brr(i, 1)
  40.                         brr(i, 1) = brr(p, 1)
  41.                         brr(p, 1) = temp
  42.                     End If
  43.                 End If
  44.             Next
  45.             .Cells(4, 6 + j).Resize(r - 3, 1) = arr
  46.         Next
  47.     End With
  48. End Sub


复制代码

评分

1

查看全部评分

回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2024-12-24 14:40 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
详见附件。

如何根据标准列顺序对原始列重新排序三种顺序.rar

16.24 KB, 下载次数: 5

评分

1

查看全部评分

回复

举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-12-25 02:51 , Processed in 0.046178 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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