|
- Sub aa()
- Dim sh As Worksheet, arr, i&, rng As Range, ar(), k&, m&, ar1, s&, p&, n&
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Sheet1
- For Each rng In .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
- If rng.Offset(1, 0) = "" Then
- MsgBox rng.Value & "不存在相关数据"
- Exit Sub
- End If
- If rng.Value <> "" Then
- 100:
- For Each sh In Worksheets
- If rng.Value = sh.Name Then
- s = s + 1
- arr = rng.Offset(1, 0).Resize(.Cells(.Columns(rng.Column).Rows.Count, rng.Column).End(xlUp).Row - 1, 2)
- Do
- Randomize
- k = Int(Rnd() * UBound(arr) + 1)
- d(k) = arr(k, 1) & "" & arr(k, 2)
- Loop Until d.Count = UBound(arr)
- ar1 = d.items
- p = 2
- n = 1
- ReDim Preserve ar(1 To UBound(ar1) / 2, 1 To 5)
- For m = 0 To UBound(ar1)
- If m Mod 5 = 0 And m <> 0 Then
- p = p + 2
- n = 1
- End If
- ar(p - 1, n) = Split(ar1(m), "")(0)
- ar(p, n) = Split(ar1(m), "")(1)
- n = n + 1
- Next
- sh.Range("a1").Resize(UBound(ar), UBound(ar, 2)) = ar
- Erase ar
- d.RemoveAll
- End If
- Next
- If s = 0 Then
- Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
- sh.Name = rng.Value
- GoTo 100
- End If
- End If
- s = 0
- Next
- End With
- End Sub
复制代码 |
|