ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

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

[原创] vba自动生成旋转数字序列

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-9-9 16:40 | 显示全部楼层 |阅读模式
先看示意图:
微信截图_20180909163037.png


发帖本意:
       看见超版用函数做出来了,很是惊奇!非常佩服!!!这个函数都可以做出来,那我vba呢?答案是肯定的!!!可是要如何实现呢?
今天是星期天,加班,办公室人少,中午本来午休的,可是禁不住要思考!!!于是就琢磨着:功夫不负有心人……
希望有其他好的方法,大家共享学习!!!
下面是超版的函数版附件:

旋转数字序列-超人.rar (22.66 KB, 下载次数: 38)

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-9 16:43 | 显示全部楼层
这是我vba实现的代码:
  1. Sub main()
  2. Dim s As Integer
  3. Dim i As Integer
  4. Dim a As Integer
  5. Dim c As Integer
  6. Dim w As Integer
  7. Dim d As Integer
  8. Dim ii As Integer
  9. Dim h As Integer
  10. Application.ScreenUpdating = False
  11. Cells.ClearContents
  12. w = InputBox("请输入奇数维数!!!")
  13. s = w * w
  14. i = (w + 1) / 2
  15. b = w
  16. For a = w To i Step -1
  17. 1000:
  18.     For c = 1 To b
  19.         If Cells(a, c) = "" Then
  20.             Cells(a, c) = s
  21.             s = s - 1
  22.             If s = 0 Then Exit Sub
  23.         End If
  24.     Next c
  25.     a = a - 1
  26.     GoTo 100
  27. Next a
  28. 100:
  29. For d = VBA.IIf(d, d, w) To i Step -1
  30.     For e = b To 1 Step -1
  31.         If Cells(e, d) = "" Then
  32.             Cells(e, d) = s
  33.             s = s - 1
  34.             If s = 0 Then Exit Sub
  35.         End If
  36.     Next e
  37.     d = d - 1
  38.     GoTo 10
  39. Next d
  40. 10:
  41. For h = VBA.IIf(h, h, 1) To i
  42.     For g = w To 1 Step -1
  43.         If Cells(h, g) = "" Then
  44.             Cells(h, g) = s
  45.             s = s - 1
  46.             If s = 0 Then Exit Sub
  47.         End If
  48.     Next g
  49.     h = h + 1
  50.     GoTo 1:
  51. Next h
  52. 1:
  53. For ii = VBA.IIf(ii, ii, 1) To i
  54.     For jj = 1 To b
  55.         If Cells(jj, ii) = "" Then
  56.             Cells(jj, ii) = s
  57.             s = s - 1
  58.             If s = 0 Then Exit Sub
  59.         End If
  60.     Next jj
  61.     ii = ii + 1
  62.     GoTo 1000:
  63. Next ii
  64. Application.ScreenUpdating = True
  65. End Sub
复制代码
没有什么高级的算法!!!搭积木堆砌而成!!!希望看见其他好的算法!!!

评分

参与人数 3财富 +20 鲜花 +4 收起 理由
YZC51 + 2 太强大了
lsc900707 + 20 太强大了
chxw68 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-9 16:47 | 显示全部楼层
下面是我vba的附件:


vba自动生成旋转数字序列.rar (16.45 KB, 下载次数: 27)

评分

参与人数 1鲜花 +2 收起 理由
chxw68 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-9-9 20:59 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-10 07:23 | 显示全部楼层
jiminyanyan 发表于 2018-9-9 20:59
版主重出江湖啦。。。

哈哈,一直都在!!!
只是后浪推前浪!!!

TA的精华主题

TA的得分主题

发表于 2018-9-10 08:53 | 显示全部楼层
  1. Sub test()
  2.   Dim i%, j%, m%, n%, w%
  3.   Dim arr()
  4.   w = Application.InputBox(prompt:="请输入奇数维数", Title:="操作提示", Default:=21, Type:=1)
  5.   If w Mod 2 = 0 Then
  6.     MsgBox "输入的维数不是奇数!"
  7.     Exit Sub
  8.   End If
  9.   a = Int(w / 2) + 1
  10.   ReDim arr(1 To w, 1 To w)
  11.   m = a
  12.   n = a
  13.   For i = 1 To w ^ 2
  14.     arr(m, n) = i
  15.     If m >= a Then
  16.       If n >= a Then
  17.         If arr(m, n - 1) = "" Then
  18.           n = n - 1
  19.         Else
  20.           m = m + 1
  21.         End If
  22.       Else
  23.         If arr(m - 1, n) = "" Then
  24.           m = m - 1
  25.         Else
  26.           n = n - 1
  27.         End If
  28.       End If
  29.     Else
  30.       If n < a Then
  31.         If arr(m, n + 1) = "" Then
  32.           n = n + 1
  33.         Else
  34.           m = m - 1
  35.         End If
  36.       Else
  37.         If arr(m + 1, n) = "" Then
  38.           m = m + 1
  39.         Else
  40.           n = n + 1
  41.         End If
  42.       End If
  43.     End If
  44.   Next
  45.   With Worksheets("sheet1")
  46.     .Cells.Clear
  47.     .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
  48.     .Columns(1).Resize(, w).AutoFit
  49.   End With
  50. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-9-10 08:56 | 显示全部楼层
看到版主对此题这么有兴趣,心手也非常痒痒,从昨天到今天一直琢磨,终于今天早晨实现要求,在此献丑了。

旋转填充序列数.rar

15.79 KB, 下载次数: 30

评分

参与人数 1技术 +1 收起 理由
ctp_119 + 1 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-9-10 08:57 | 显示全部楼层
观察 1,9,25,49,81,121,169,225,... ...

正好是 奇数{1,3,5,7,9,11,13,15,...} 的平方值

163433x3h7j57aravyy715.png

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-10 10:12 | 显示全部楼层
chxw68 发表于 2018-9-10 08:56
看到版主对此题这么有兴趣,心手也非常痒痒,从昨天到今天一直琢磨,终于今天早晨实现要求,在此献丑了。

谢谢捧场!!!下载学习一下!!!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-10 10:13 | 显示全部楼层
zopey 发表于 2018-9-10 08:57
观察 1,9,25,49,81,121,169,225,... ...

正好是 奇数{1,3,5,7,9,11,13,15,...} 的平方值

函数是超版做的,我没有深究,太复杂的函数,烧脑!!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2019-12-15 13:24 , Processed in 0.430240 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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