Excel精英培训网

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

[已解决]请高手看下这个指定单元格随机移动的问题,谢谢高手的帮忙

[复制链接]
发表于 2013-9-21 07:54 | 显示全部楼层 |阅读模式
想出题给孩子做,但如若是每次以复制粘贴的方式来调整题的位置的话,实在是太慢了,恳请高手帮忙看下,能否提供一个代码让我得到我想要的结果。我附件上有一表,在a1:d26中每个单元格中都有不同的算术,我想得到一个代码,当我执行他的时候,他会把这些单元格随机调换位置,例如a1单元格的内容和b15对换等等,谢谢高手的帮忙
最佳答案
2013-9-21 08:21
本帖最后由 zjdh 于 2013-9-21 08:25 编辑

直接出题不更好?
数学练习.rar (16.68 KB, 下载次数: 4)

算术.rar

2.2 KB, 下载次数: 5

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-9-21 08:16 | 显示全部楼层
  1. Sub 换位()
  2.     Dim arr, i As Integer, j As Integer
  3.     Dim strTemp As String
  4.     Dim r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer
  5.     arr = Range("a1").CurrentRegion.Value
  6.     i = Application.InputBox("请输入数据换位的个数[>=2]", "提示", 5, , , , , 1)
  7.     If i < 2 Then
  8.         MsgBox "换位数次不对"
  9.         Exit Sub
  10.     End If
  11.     For j = 1 To i
  12.         Do
  13.         r1 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  14.         r2 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  15.         c1 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  16.         c2 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  17.         Loop Until r1 <> r2 And c1 <> c2
  18.         strTemp = arr(r1, c1)
  19.         arr(r1, c1) = arr(r2, c2)
  20.         arr(r2, c2) = strTemp
  21.      Next
  22.     Range("a1").CurrentRegion.Value = arr
  23.     MsgBox "换位完成"
  24. End Sub
复制代码
回复

使用道具 举报

发表于 2013-9-21 08:20 | 显示全部楼层
  1. Sub 换位()
  2.     Dim arr, i As Integer, j As Integer
  3.     Dim strTemp As String
  4.     Dim r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer
  5.     arr = Range("a1").CurrentRegion.Value
  6.     i = Application.InputBox("请输入数据换位的次数[>=2]" & vbCrLf & vbCrLf & "次数越大越好", "提示", 30, , , , , 1)
  7.     If i < 2 Then
  8.         MsgBox "换位数次不对"
  9.         Exit Sub
  10.     End If
  11.     For j = 1 To i
  12.         Do
  13.             r1 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  14.             r2 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  15.             c1 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  16.             c2 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  17.         Loop Until r1 <> r2 Or c1 <> c2
  18.         '条件换成or后,同行不同列或同列不同行也能换位
  19.         '原来条件用AND,要求不同行不同列才能交换
  20.         strTemp = arr(r1, c1)
  21.         arr(r1, c1) = arr(r2, c2)
  22.         arr(r2, c2) = strTemp
  23.     Next
  24.     Range("a1").CurrentRegion.Value = arr
  25.     MsgBox "换位完成"
  26. End Sub
复制代码
回复

使用道具 举报

发表于 2013-9-21 08:21 | 显示全部楼层
算术.rar (10.6 KB, 下载次数: 1)
回复

使用道具 举报

发表于 2013-9-21 08:21 | 显示全部楼层    本楼为最佳答案   
本帖最后由 zjdh 于 2013-9-21 08:25 编辑

直接出题不更好?
数学练习.rar (16.68 KB, 下载次数: 4)
回复

使用道具 举报

发表于 2013-9-21 08:24 | 显示全部楼层
不用对话框输入交换的次数。
  1. Sub 换位()
  2.     Dim arr, i As Integer, j As Integer
  3.     Dim strTemp As String
  4.     Dim r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer
  5.     arr = Range("a1").CurrentRegion.Value
  6.     If Not IsArray(arr) Then MsgBox "A1所在的区域数据不足以生成数据", vbCritical: Exit Sub
  7.     i = UBound(arr) * UBound(arr, 2) /2
  8.     For j = 1 To i
  9.         Do
  10.             r1 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  11.             r2 = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  12.             c1 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  13.             c2 = WorksheetFunction.RandBetween(LBound(arr, 2), UBound(arr, 2))
  14.         Loop Until r1 <> r2 Or c1 <> c2
  15.         '条件换成or后,同行不同列或同列不同行也能换位
  16.         '原来条件用AND,要求不同行不同列才能交换
  17.         strTemp = arr(r1, c1)
  18.         arr(r1, c1) = arr(r2, c2)
  19.         arr(r2, c2) = strTemp
  20.     Next
  21.     Range("a1").CurrentRegion.Value = arr
  22.     MsgBox "换位完成"
  23. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 13:26 , Processed in 0.465971 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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