[已解决]随机乱序并生成工作薄的问题(修改代码)

小玲玲 · 发表于 2016-3-19 16:44

本帖最后由小玲玲于 2016-3-22 19:49 编辑

附件

随机乱序并生成文件附件.rar (80.95 KB, 下载次数: 8)

josonxu · 发表于 2016-3-22 07:23

这个最佳答案由 josonxu 给出，感谢 josonxu 的回答。

单击隐藏图章

操作.zip (145.33 KB, 下载次数: 24)

小玲玲 · 发表于 2016-3-22 22:12

josonxu 发表于 2016-3-22 07:23
会在结果文件夹内生成49个屏幕更新我关了文件多数据多 cpu是考验

谢谢老师帮助．有个小问题，麻烦老师看看．

所生成的工作薄中，工作表只有Sheet1. 给后续操作带来诸多不便．
希望所生成的工作薄，都有三个工作表Sheet1 Sheet2 Sheet3

谢谢．

josonxu · 发表于 2016-3-22 22:28

小玲玲发表于 2016-3-22 22:12
谢谢老师帮助．有个小问题，麻烦老师看看．

所生成的工作薄中，工作表只有Sheet1. 给后续操作带来诸多 ...

Sub test()
Application.ScreenUpdating = False
Sheet1.UsedRange.ClearContents
Dim i&, s&, j&, r&, arr, k
For s = 1 To 49
      arr = Range("A1").CurrentRegion
      For i = 1 To UBound(arr, 2)
         For j = 1 To UBound(arr)
            r = Int(Rnd() * UBound(arr) + 1)
            T = arr(j, i)
            arr(j, i) = arr(r, i)
            arr(r, i) = T
         Next
      Next
      Sheet2.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
      Sheet1.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
      Sheet1.Copy
      For k = 1 To 2
         Sheets.Add After:=Sheets(Sheets.Count)
      Next
      ActiveWorkbook.Close True, ThisWorkbook.Path & "\结果\" & s & ".xlsx"
Next
Application.ScreenUpdating = True
MsgBox "重排完成！"
End Sub

小玲玲 · 发表于 2016-3-22 22:54

josonxu 发表于 2016-3-22 22:28
Sub test()
Application.ScreenUpdating = False
Sheet1.UsedRange.ClearContents

谢谢老师了．看了一下，还是有一点小问题．
为什么显示的不是 Sheet1 而是 Sheet3?
希望显示的是Sheet1，呈现在眼前的是看得见的数据．

谢谢了．

josonxu · 发表于 2016-3-22 22:58

本帖最后由 josonxu 于 2016-3-22 23:26 编辑

小玲玲发表于 2016-3-22 22:54
谢谢老师了．看了一下，还是有一点小问题．
为什么显示的不是 Sheet1 而是 Sheet3?
希望显示的是Sheet ...

你加一段激活 sheet1的代码就行了红色代码下面加上sheet1.Activate 需要自己灵活运用这个不难

小玲玲 · 发表于 2016-3-22 23:17

josonxu 发表于 2016-3-22 22:58
你加一段激活 sheet1的代码就行了红色代码下面加上sheet1.Activate 需要自己灵活运用这个不难

老师啊，我就是菜菜一个，我把sheet1.Activate加在红色代码后，试了一下，运行不了．
麻烦老师帮帮我啊，谢谢了．祝好人一生平安．

josonxu · 发表于 2016-3-22 23:25

小玲玲发表于 2016-3-22 23:17
老师啊，我就是菜菜一个，我把sheet1.Activate加在红色代码后，试了一下，运行不了．
麻烦老师帮帮我啊， ...

Sub test()
Application.ScreenUpdating = False
Sheet1.UsedRange.ClearContents
Dim i&, s&, j&, r&, arr, k
For s = 1 To 49
      arr = Range("A1").CurrentRegion
      For i = 1 To UBound(arr, 2)
         For j = 1 To UBound(arr)
            r = Int(Rnd() * UBound(arr) + 1)
            T = arr(j, i)
            arr(j, i) = arr(r, i)
            arr(r, i) = T
         Next
      Next
      Sheet2.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
      Sheet1.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
      Sheet1.Copy
      For k = 1 To 2
         Sheets.Add After:=Sheets(Sheets.Count)
      Next
      ActiveWorkbook.Sheets(1).Activate
      ActiveWorkbook.Close True, ThisWorkbook.Path & "\结果\" & s & ".xlsx"
Next
Application.ScreenUpdating = True
MsgBox "重排完成！"
End Sub

小玲玲 · 发表于 2016-3-22 23:48

josonxu 发表于 2016-3-22 23:25
Sub test()
Application.ScreenUpdating = False
Sheet1.UsedRange.ClearContents

谢谢老师了，再谢．

		自动登录	找回密码
密码			注册