Cảm ơn các bác
Đề yêu cầu tạo 150 bảng 4x5
Mỗi ô trong bảng chứa các số từ 1-20 không trùng nhau. Các bảng có thể trùng hoặc không
Mong các bác giúp e
Public Sub GPE()
Dim Arr(1 To 750, 1 To 5), I As Long, J As Long, N As Long, K As Long, R As Long, Num As Long
With CreateObject("Scripting.Dictionary")
Randomize
R = 1
For N = 1 To 150
For I = R To R + 3
For J = 1 To 5
Do
Num = Int(Rnd * 20) + 1
If Not .Exists(Num) Then
.Add Num, ""
Arr(I, J) = Num
Exit Do
End If
Loop
Next J
Next I
R = R + 5
.RemoveAll
Next N
End With
Range("A1").Resize(750, 5) = Arr
End Sub
Dim StrC As String
Sub Tao150BangSo()
Dim J As Long, Hg As Long, Cot As Byte
Dim Tmp As String
StrC = ""
For J = 1 To 20
If J Mod 2 = 0 Then
StrC = StrC & Right("0" & CStr(J), 2)
Else
StrC = Right("0" & CStr(J), 2) & StrC
End If
Next J
For J = 1 To 900 Step 3
Tron StrC: Tmp = StrC
For Hg = J To J + 3
For Cot = 1 To 5
Cells(Hg + J, Cot).Value = Mid(Tmp, 2 * Cot - 1, 2)
Next Cot
Tmp = Mid(Tmp, 11, Len(StrC))
Next Hg
Next J
End SubSub Tron(StrC As String)
Dim J As Long, VTr As Byte
Randomize
For J = 1 To 49
VTr = 7 + 9 * Rnd() \ 1
If VTr Mod 2 = 0 Then VTr = VTr + 1
If VTr > 10 Then
StrC = Mid(StrC, VTr, Len(StrC)) & Mid(StrC, 9, VTr - 9) & Left(StrC, 8)
Else
StrC = Mid(StrC, VTr, 13 - VTr) & Left(StrC, VTr - 1) & Mid(StrC, 13, Len(StrC))
End If
Next J
End Subdùng Array thay Dictionary
Sub GPE()
Dim Arr(), Cond() As Boolean, i As Long, j As Byte, n As Long, S, R As Long, Tmp As Byte
R = Range("A" & Rows.Count).End(xlUp).Row
If R > 1 Then Range("A2:E" & R).ClearContents
S = [D1].Value
If IsNumeric(S) Then
If S < 1 Or S > 200000 Then S = 150 Else S = Int(S)
Else: S = 150
End If
ReDim Cond(1 To 20)
ReDim Arr(1 To S * 5, 1 To 5)
Randomize
R = 1
For n = 1 To S
For i = R To R + 3
For j = 1 To 5
Do
Tmp = Int(Rnd * 20) + 1
If Cond(Tmp) = False Then
Cond(Tmp) = True
Arr(i, j) = Tmp
Exit Do
End If
Loop
Next j
Next i
R = R + 5
ReDim Cond(1 To 20)
Next n
Range("A2").Resize(S * 5, 5) = Arr
End Sub
Function UniqueMatrix(ByVal mHeight As Long, ByVal mWidth As Long)
Dim lR As Long, lC As Long, n As Long, i As Long, lPos As Long, lTmp As Long
'Application.Volatile
If mWidth * mHeight > 0 Then
ReDim aDes(1 To mHeight, 1 To mWidth)
n = mHeight * mWidth
ReDim arr(1 To n) As Long
Randomize
For i = 1 To mHeight * mWidth
lR = Int((i - 1) / mWidth) + 1
lC = ((i - 1) Mod mWidth) + 1
lPos = Int(Rnd() * n) + 1
If arr(lPos) = 0 Then arr(lPos) = lPos
If arr(n) = 0 Then arr(n) = n
aDes(lR, lC) = arr(lPos)
lTmp = arr(lPos): arr(lPos) = arr(n): arr(n) = lTmp
n = n - 1
Next
UniqueMatrix = aDes
End If
End FunctionSub Main()
Const mHeight = 4: Const mWidth = 5
Const lHT = 30: Const lWT = 5
Dim i As Long, lR As Long, lC As Long, lTmp As Long
For i = 1 To lHT * lWT
lR = Int((i - 1) / lWT) * (mHeight + 1) + 1
lC = ((i - 1) Mod lWT) * (mWidth + 1) + 1
Cells(lR, lC).Resize(mHeight, mWidth).Value = UniqueMatrix(mHeight, mWidth)
Next
End Subthuật toán tìm số ngẩu nhiên không trùng của bạn rất hay, chạy thử vài lần mình mới hiểu được
mình chỉnh lại một chút gọn hơn và tăng được tốc độ code
Function UniqueMatrix(ByVal mHeight As Long, ByVal mWidth As Long)
Dim lR As Long, lC As Long, n As Long, i As Long, lPos As Long
'Application.Volatile
If mWidth * mHeight > 0 Then
ReDim aDes(1 To mHeight, 1 To mWidth)
n = mHeight * mWidth
ReDim Arr(1 To n) As Long
Randomize
For i = 1 To mHeight * mWidth
lR = Int((i - 1) / mWidth) + 1
lC = ((i - 1) Mod mWidth) + 1
lPos = Int(Rnd() * n) + 1
[COLOR=#ff0000] If Arr(lPos) = 0 Then Arr(lPos) = lPos[/COLOR]
[COLOR=#ff0000] aDes(lR, lC) = Arr(lPos)[/COLOR]
[COLOR=#ff0000] If Arr(n) = 0 Then Arr(lPos) = n Else Arr(lPos) = Arr(n)[/COLOR]
n = n - 1
Next
UniqueMatrix = aDes
End If
End Functionthuật toán tìm số ngẩu nhiên không trùng của bạn rất hay, chạy thử vài lần mình mới hiểu được
tạo nhiều vòng lập để dể viết và giảm khối lượng tính toán làm tăng tốc độ của code
cám ơn bạn chúc bạn một ngày vui
theo gợi ý của bạn
Sub Main()
Dim Darr As Variant, Arr As Variant, sTable As Long, s As Long, R As Long, k As Long, i As Integer, j As Integer
Const iR = 4: Const jC = 5
sTable = 150
ReDim Arr(1 To (iR + 1) * sTable, 1 To jC)
' chon 1 trong 2
'For s = 1 To sTable
'Darr = UniqueRandom(iR * jC)
'R = (s - 1) * (iR + 1)
'k = 0
'For i = 1 To iR
'For j = 1 To jC
'k = k + 1
'Arr(i + R, j) = Darr(k)
'Next j
'Next i
'Next s
'******
For s = 1 To sTable
Darr = UniqueTable(iR, jC)
k = (s - 1) * (iR + 1)
For i = 1 To iR
For j = 1 To jC
Arr(i + k, j) = Darr(i, j)
Next j
Next i
Next s
[A2].Resize(sTable * (iR + 1), jC) = Arr
End Sub
Function UniqueTable(ByVal iR As Integer, ByVal jC As Integer) As Variant
Dim Darr As Variant, Arr As Variant, i As Integer, j As Integer, k As Long
ReDim Arr(1 To iR, 1 To jC)
Darr = UniqueRandom(iR * jC)
For i = 1 To iR
For j = 1 To jC
k = k + 1
Arr(i, j) = Darr(k)
Next j
Next i
UniqueTable = Arr
End Function
Function UniqueRandom(ByVal N As Long) As Variant
Dim Arr As Variant, Darr As Variant, Tmp As Long, i As Long
ReDim Arr(1 To N): ReDim Darr(1 To N)
Randomize
For i = 1 To N
Tmp = Int(Rnd() * N) + 1
If Darr(Tmp) = 0 Then Darr(Tmp) = Tmp
Arr(i) = Darr(Tmp)
If Darr(N) = 0 Then Darr(Tmp) = N Else Darr(Tmp) = Darr(N)
N = N - 1
Next i
UniqueRandom = Arr
End Function' sub tron mang ngau nhien
' thuat toan:
' 1. dùng hàm rnd để chọn vị trí (từ đầu mảng đến cuối mảng)
' 2. hoán vị phần tử được chọn với phần tử đầu mảng
' 3. dời đầu mảng về bên phải 1 vi trí
' 4. tiếp tục lặp lại bước 1
Sub TronMang(mang, optional thucNN = true)
if thucNN Then Randomize
dim lo, hi, tmp
hi = ubound(mang)
for lo = lbound(mang) to hi-1
pos = CInt(Rnd*(hi-lo)+lo)
' doi cho voi phan tu o dau mang
tmp = mang(lo)
mang(lo) = mang(pos)
mang(pos) = tmp
next i
End Sub
Sub/function Mang1To2(...)
End Sub/Function
Sub Main()
dim mang as variant
dim so(1 to 20) as Integer, i as integer
for i = 1 to 20
so(i) = i
next i
Randomize
for i = 150
mang = so
TronMang mang, false
... doi thanh 2 chieu o day
... ghi vao sheet o day
next i
End Sub
