Hỗ trợ kiểu gì vậy bạn.
Ví dụ 1 2 3 4 5 7 2 1 3 sẽ tạo thành các dãy số có 2 chữ số không bị trùng nhau ạ.
Dạ. Ví dụ e đang có số: 1, 2, 5, 7, 9. Em muốn tạo dãy có 2 chữ sô như: 12, 15, 51, 57, 75 ... k bị trùng nhau ạ.
Đơn giản
Vẫn còn dư các số 11, 22, 33,...
Đó là nếu "lấy 2"
Xem bài #3 thì các chữ số cho trước có quyền được trùng thì phải.
Biết rằng đang các chú siêu nhân ở đây,nhưng cháu vẫn xin mạo muội góp vui một cách, được thì được là trời cho còn không được thì là trò chơi:
Option Explicit
Private Function CreateRandomString(Optional ByVal lengthOfOutput As Long = 8, Optional ByVal minimumCountOfNumbers As Long = 1, Optional ByVal minimumCountOfLetters As Long = 1, Optional ByVal minimumCountOfSymbols As Long = 1) As String
Dim countRemaining As Long
countRemaining = lengthOfOutput - (minimumCountOfLetters + minimumCountOfNumbers + minimumCountOfSymbols)
Debug.Assert countRemaining >= 0
Const LETTERS_ALLOWED As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const NUMBERS_ALLOWED As String = "0123456789"
Const SYMBOLS_ALLOWED As String = "!""£$%^&*()-_+[]{};:'@#" ' Change as necessary, I do not know what symbols you want included.
Dim toJoin() As String
ReDim toJoin(1 To 4)
toJoin(1) = GetRandomCharactersFromText(LETTERS_ALLOWED, minimumCountOfLetters, duplicatesAllowed:=False)
toJoin(2) = GetRandomCharactersFromText(NUMBERS_ALLOWED, minimumCountOfNumbers, duplicatesAllowed:=False)
toJoin(3) = GetRandomCharactersFromText(SYMBOLS_ALLOWED, minimumCountOfSymbols, duplicatesAllowed:=False)
' I arbitrarily pad the rest of the string with random letters, but you can change this logic.
toJoin(4) = GetRandomCharactersFromText(LETTERS_ALLOWED, countRemaining, duplicatesAllowed:=False)
Dim outputString As String
outputString = Join(toJoin, vbNullString)
' This step is meant to scramble the characters in the string.
' Otherwise, the returned string's structure would reflect the code above:
' • w letters, followed by x numbers, followed by y symbols, followed by z characters
' which stops it being pseudo-random.
outputString = GetRandomCharactersFromText(outputString, Len(outputString), False)
CreateRandomString = outputString
End Function
Private Function RandomBetween(ByVal lowerLimit As Long, ByVal upperLimit As Long) As Long
' Could use Application.RandBetween instead (maybe). But maybe there is some performance difference.
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/rnd-function
RandomBetween = Int((upperLimit - lowerLimit + 1) * Rnd + lowerLimit)
End Function
Private Function GetRandomCharactersFromText(ByVal someText As String, ByVal numberOfCharactersToGet As Long, Optional ByVal duplicatesAllowed As Boolean = True) As String
' Returns n characters from a given string. Characters are chosen pseudo-randomly.
' "duplicatesAllowed" controls whether a given index can be chosen more than once.
Dim chosenIndexes() As Long
ReDim chosenIndexes(1 To numberOfCharactersToGet)
Dim characterIndex As Long
For characterIndex = 1 To numberOfCharactersToGet
Do While True
Dim randomCharacterIndex As Long
randomCharacterIndex = RandomBetween(1, Len(someText))
If duplicatesAllowed Then Exit Do
If IsError(Application.Match(randomCharacterIndex, chosenIndexes, 0)) Then Exit Do
Loop
chosenIndexes(characterIndex) = randomCharacterIndex
Next characterIndex
Dim chosenCharacters() As String
ReDim chosenCharacters(1 To numberOfCharactersToGet)
For characterIndex = 1 To numberOfCharactersToGet
randomCharacterIndex = chosenIndexes(characterIndex)
chosenCharacters(characterIndex) = Mid(someText, randomCharacterIndex, 1)
Next characterIndex
GetRandomCharactersFromText = Join(chosenCharacters, vbNullString)
End Function=GetRandomCharactersFromText("123457213",2)Bài nầy giống dạng tổ hợp không lặp
Làm sao biết kết quả có tất cả 10 số/chuỗi?
Bác ơi em quét tù mù thôi, em không đếm, nếu quét quá tay có lẽ là trùng.
Trước đó gõ =ROWS(GetRandomCharactersFromText("123457213",2)) thì sẽ được số kết quả.
hay quá đúng là trời cho cảm ơn bác đã chỉ.
Code khá phức tạp phải qua trung gian 2 Function Tohop_N_Chap_K và HoanVi
Sub ChinhHopChap_k()
Dim DuLieu$, aToHop, aHoanVi(), Res()
Dim srTH&, srHV&, N&, k&, i&, r&, id&, j&
Dim sTH$, tmp$, str$
DuLieu = "12579" 'Chuoi cac ky tu so
k = 2 'So ky tu ket qua
N = Len(DuLieu)
str = String(k, "#")
aHoanVi = HoanVi(k)
Call ChuyenMangSo(aHoanVi, k)
aToHop = Tohop_N_Chap_K(N, k)
srTH = UBound(aToHop): srHV = UBound(aHoanVi)
ReDim Res(1 To srTH * srHV)
For i = 1 To srTH
sTH = aToHop(i, 1)
tmp = Empty
For j = 1 To N
If Mid(sTH, j, 1) = "1" Then
tmp = tmp & Mid(DuLieu, j, 1)
End If
Next j
For r = 1 To srHV
For j = 1 To k
Mid(str, j, 1) = Mid(tmp, aHoanVi(r, j), 1)
Next j
id = id + 1
Res(id) = str
Next r
Next i
Range("A2").NumberFormat = "@"
Range("A2") = Join(Res, ",")
End Sub
Function Tohop_N_Chap_K(ByVal N As Long, ByVal k As Long) As Variant
'Tao to hop N chap K, bieu dien bang chuoi các ký tu "0" va "1"
'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
Dim Arr() As String, tmp$, j&, p&, S&
ReDim Arr(1 To Application.Combin(N, k), 1 To 1)
tmp = String(k, "1") & String(N - k, "0")
p = 1: Arr(p, 1) = tmp
If k = N Then Tohop_N_Chap_K = Arr: Exit Function
Do
j = InStrRev(tmp, "1")
Mid(tmp, j, 1) = "0"
Mid(tmp, j + 1, S + 1) = String(S + 1, "1")
S = 0: p = p + 1: Arr(p, 1) = tmp
If InStr(j + 1, tmp, "0") = 0 Then
S = N - j
Mid(tmp, j + 1, S) = String(S, "0")
End If
Loop Until S = k
Tohop_N_Chap_K = Arr
End Function
Function HoanVi(ByVal Q&)
'Q là so gia tri can hoan vi, gioi han tu 1 toi 9
'Tao Hoan Vi cua Q so, bieu dien bang chuoi cac so thu tu
Dim Res(), Arr, N&, i&, k&, j As Double, sRow&
ReDim Res(1 To 1, 1 To 1)
Res(1, 1) = "1"
For N = 2 To Q
Arr = Res: k = 0
sRow = UBound(Arr)
ReDim Res(1 To N * sRow, 1 To 1)
For j = 1 To sRow
k = k + 1
Res(k, 1) = Arr(j, 1) & N
For i = N To 2 Step -1
k = k + 1
Res(k, 1) = Res(k - 1, 1)
Mid(Res(k, 1), i, 1) = Mid(Res(k, 1), i - 1, 1)
Mid(Res(k, 1), i - 1, 1) = N
Next
Next
Next N
HoanVi = Res
End Function
Sub ChuyenMangSo(ByRef aHoanVi, ByVal k&)
Dim Res(), sRow&, i&, j&, tmp$
sRow = UBound(aHoanVi)
ReDim Res(1 To sRow, 1 To k)
For i = 1 To sRow
tmp = aHoanVi(i, 1)
For j = 1 To k
Res(i, j) = CLng(Mid(tmp, j, 1))
Next j
Next i
aHoanVi = Res
End Sub
Giả dụ các số (cần để ghép đôi) của bạn đang ở cột [ b] , bắt đầu từ [B2]
Sub TaoCacCapSo()
Dim Rng As Range, Rg1 As Range, WF As Object, Rg2 As Range, Dic As Object
Dim j As Long, W As Integer, Z As Long, Num As Integer, Dm As Long, Rws As Long
Rws = [b2].CurrentRegion.Rows.Count
Set Rng = [b2].Resize(Rws)
Rng.Offset(, 1).Resize(9).ClearContents
Rng.Offset(, -1).Resize(9).ClearContents
Set WF = Application.WorksheetFunction
Set Dic = CreateObject("scripting.dictionary")
Rng.Copy Destination:=Rng(1).Offset(, -1)
Rng.Copy Destination:=Rng(1).Offset(, 1)
ReDim Arr(1 To 99 * Rng.Cells.Count, 1 To 1)
[G2].Resize(99 * Rng.Cells.Count).Value = ""
Set Rg2 = Rng.Offset(, 1)
Set Rg1 = Rng.Offset(, -1)
For j = 1 To Rng.Cells.Count - 1
For Z = j + 1 To Rg2.Cells.Count
If Rg2(Z).Value <> Space(0) Then
Num = 10 * Rng(j).Value + Rg2(Z).Value
If Not Dic.exists(Num) Then
W = W + 1: Dic.Add Num, W
Arr(W, 1) = Num
End If
Num = Rng(j).Value + 10 * Rg1(Z).Value
If Not Dic.exists(Num) Then
W = W + 1: Dic.Add Num, W
Arr(W, 1) = Num
End If
End If
Next Z
Next j
[G2].Resize(W).Value = Arr()
End SubSub Main()
Dim arr, res
arr = Array("", "1", "2", "3", "4", "5")
Range("B2").CurrentRegion.ClearContents
res = ChinhHop(arr, 3)
Range("B2").Resize(UBound(res)).NumberFormat = "@"
Range("B2").Resize(UBound(res)) = res
End Sub
Function ChinhHop(ByVal aStr, ByVal k&) As Variant
'aStr : La mang 1 chieu luu các giá tri chuoi chi có 1 ký tu
'K : Chap k
Dim arr, res(), sRow&, i&, j&, M&, Q&, id&, tmp$
arr = ChinhHop_Lap(aStr, k)
M = UBound(aStr)
ReDim res(1 To Application.Fact(M) / Application.Fact(M - k), 1 To 1)
Q = k - 1
sRow = UBound(arr)
For i = 1 To sRow
tmp = arr(i, 1)
For j = 1 To Q
If InStr(1, Mid(tmp, j + 1, Q), Mid(tmp, j, 1)) > 0 Then Exit For
Next j
If j = k Then
id = id + 1
res(id, 1) = tmp
End If
Next i
ChinhHop = res
End Function
Function ChinhHop_Lap(ByVal aStr, ByVal k&) As Variant
'aStr : La mang 1 chieu luu các giá tri chuoi chi có 1 ký tu
'K : Chap k
Dim arr() As String, res() As String
Dim M&, n&, i&, r&, j&, sRow&, tmp$
M = UBound(aStr)
ReDim res(1 To M ^ k, 1 To 1)
sRow = 1: r = 1
res(r, 1) = String(k, aStr(1))
For n = k To 1 Step -1
For j = 2 To M
For i = 1 To sRow
tmp = res(i, 1)
Mid(tmp, n, 1) = aStr(j)
r = r + 1
res(r, 1) = tmp
Next i
Next j
sRow = r
Next n
ChinhHop_Lap = res
Erase arr
End Function
