Chọn ngẫu nhiên theo

MinhK · 13/6/08

HI, các anh chi trong diễn đàn

Tôi đang muốn chuyển từ .WBT (WinBatch) sang VBA vì cảm thấy WBT chạy châm lại khi đổi sang xlsm.2007 và vất vả với 5000 cột 3500 dòng ! (Có lẽ tại anh Bill nhiếu hơn)
Book1.2.xls, dùng WBT tạo ra công thức (RANDOM) cho các cell từ cột K --> IT
Random pick các số từ cột C --> J (= 8 số), tuy nhiên không lập lại 1 số đã dùng
Viết công thức ( thí dụ cell K2 : =CONCATENATE(J2,C2,G2,I2,D2,H2,F2,E2)
Số 01- 09 phải viết là 01, 02, 03... 09 (Char)
Cứ như thế chạy từ K tới IT.
Với các dòng thì chỉ copy là đươc.
Mong các bạn giúp đoạn code như thế nào để viết được công thức như trên
theo cách WBT, tôi cũng bi trùng lặp ở vài cột, (chưa hoàn chỉnh lắm ạ)
Cảm ơn các bạn trước.
MK

MinhK · 13/6/08

Book1.2.xls có trùng lặp một vài cột.
Xem kiêm tra qua book1.3
sheet2 , macro findup()

Po_Pikachu · 13/6/08

Bạn dùng thử hàm này xem có giúp gì được không!

PHP:

Function ngaunhien() Dim i, j As String i = Int(Rnd() * 1000000000) j = Int(Rnd() * 1000000000) ngaunhien = Left((i & j), 16) End Function

MinhK · 13/6/08

Cám ơn anh Po_Pikachu
Vâng, có random từ i, J nhưng không lấy con số nào trong cột C-J của dòng 2.
Anh xem lại xls, hy vong rõ rang hơn tôi giải thích.

Cám ơn anh .

SA_DQ · 13/6/08

Bạn tham khảo điền số vô vùng C1:J7 bất kỳ, không trùng

Các số đem dùng có thể từ 1:99,
các số <=9 sẽ có dạng 0(i)

PHP:

Option Explicit
Sub RadomNumS()
 Dim Ww As Byte
 Dim SChuoi As String, Rng As Range
 
 For Ww = 1 To 99
    If Ww < 10 Or Ww > 95 Then
        SChuoi = SChuoi & Right("0" & CStr(Ww), 2)
    Else
        If Ww Mod 2 = 0 Then
            SChuoi = Ww & Mid(SChuoi, 11) & Left(SChuoi, 10)
        Else
            SChuoi = Mid(SChuoi, 9) & Left(SChuoi, 8) & Ww
        End If
    End If
 Next Ww
 Ww = 1
 For Each Rng In Range([c1], [j7])
    Ww = Ww + 1
    Rng = Mid(SChuoi, 2 * Ww + 1, 2)
    If Rng < 10 Then Rng = "'" & "0" & Rng
 Next Rng
End Sub

MinhK · 13/6/08

Chào anh/chi HYEN17
Cám ơn H.Y dù .. không có đúng như ý tối. Có lẽ tối không biết diễn đạt ý mong cầu.
Hy vong H.Y xem lai xls thì rò hơn.(=CONCATENATE(J2,C2,G2,I2,D2,H2,F2,E2), đoạn này fải đươc code viết lên các cột K-IT dòng 2, các số của các cột C->J không quan trong, biến đổi tùy vào code của sub khác.
Thanks
MK

MinhK · 13/6/08

Thân chào các bạn
theo lý luận khi viết Winbatch thì Công việc có thể tóm tắt như thế này có được không:

Chọn lưa ngẫu nhiên các cell trong tổ hợp (c2,b2,d2,..j2)
Thiết lập một tổ hợp 8, các cells trên, theo xác xuất thì có thể có 8! cách sắp xếp khác nhau các cell của tồ hợp {C2,D2,È2,F2,G2,H2,I2,J2}
Concatenate 8 cells lại với nhau,
Ghi lai công thức này lên K2
Lâp vòng (loop) cho L2, M2,.. (j=11 tới j=245 hay hơn nữa) cho mỗi cách sắp xếp.
(chú ý là không dùng lai thành phân đả dùng rôi khi khi thiết lập 1 tổ hợp.
thí dụ :
{C2,D2,È2,F2,G2,H2,I2,J2}
{D2,C2,È2,F2,G2,H2,I2,J2}
(C2,H2,I2,E2,F2,G2,D2,J2)
Giải thích như vậy có là sáng tỏ thêm chút nào không ???

Xin lỗi đã gây confuse các bạn

MK

SA_DQ · 15/6/08

Hãy xóa đi các chuỗi trùng, có được không vậy?

Mình thấy tại sheet2 của bạn có mảco tìm chuỗi trùng rồi, giờ chỉ dùng câu lệnh xóa 1 trong từng cặp của chúng là được chưa vậy?
Mà cái danh sách 245 records bạn tạo ra bằng cách nào vậy?
Nếu bằng macro, mình tạo ra gần 370 records; Nếu bạn cần mình cung cấp cho,

Thân ái!

MinhK · 15/6/08

Hi, Anh Sa_DQ
Mấy hôm nay rấu rỉ râu ria ra râm rạp vì phố xá thì đông người qua lại mà quán minh thì vắng như chùa 1 cột. Mới anh ly nước mía nhé.
Như đã nêu trên thì tôi muốn chuyển project này từ WBT sang VB-(A?) (E?) cho nên đang tự học.
WBT thì tôi cũng đả có sub delete column trùng rồi nhưng qua VBE(A?) thì mình chỉ là lính mới to te.
245 vì book1.2/3.xls là excel.2003 chỉ có 256 column, tiên lợi khi upload.
Anh Sa_DQ ơi, tôi thèm muốn ... mà anh còn hỏi :"Nếu bằng macro, mình tạo ra gần 370 records; Nếu bạn cần mình cung cấp cho"
Mong anh post lên sớm cho tôi và các bạn dươc học hỏi.
Cám ơn anh ghé thăm và đưa tin.
MK

SA_DQ · 16/6/08

Gần gấp đôi cho bạn luôn!

Bạn xem trong file đính kèm & kiểm tra lại xem sao!

PHP:

Option Explicit

Sub ToHop8()
 Const StrC As String = "ABCDEFGH"
 Dim bA As Byte, bB As Byte, bC As Byte, bD As Byte
 Dim SChu As String, SCh0 As String, SCh1 As String, SCh3 As String
 Const KT As String = ""
 
 Range("e2:E900").Clear
 For bA = 1 To 8
    SChu = Mid(StrC, bA, 9 - bA) & Left(StrC, bA - 1)
    Range("E" & [E999].End(xlUp).Row + 1) = SChu
    
    For bB = 2 To 7
        SCh0 = Mid(SChu, 2, 7)
        SCh0 = Left(SChu, 1) & Mid(SCh0, bB, 8 - bB) & Left(SCh0, bB - 1)
        Range("E" & [E999].End(xlUp).Row + 1) = SCh0
        For bC = 3 To 6
            SCh1 = Mid(SCh0, 3, 6)
            SCh1 = Left(SCh0, 2) & Mid(SCh1, bC, 7 - bC) & Left(SCh1, bC - 1)
            Range("E" & [E999].End(xlUp).Row + 1) = SCh1
            For bD = 4 To 5
                SCh3 = Mid(SCh1, 4, 5)
                SCh3 = Left(SCh1, 3) & Mid(SCh3, bD, 6 - bD) & Left(SCh3, bD - 1)
                Range("E" & [E999].End(xlUp).Row + 1) = SCh3
            Next bD
        Next bC
    Next bB
 Next bA
 SearchDuplicat
End Sub

Mã:

[B]Sub SearchDuplicat()[/B]
On Error Resume Next
 Dim lRow As Long, Zz As Long:          Dim Rng As Range
 Sheet2.Select:              Sxep [E2]
 lRow = [E999].End(xlUp).Row
 For Zz = 2 To lRow
    With Cells(Zz, 5)
        If .Value = .Offset(-1) Then
            .Interior.ColorIndex = 35
            If Rng Is Nothing Then
                Set Rng = .Offset(-1)
            Else
                Set Rng = Union(Rng, .Offset(-1))
            End If
        End If
    End With
 Next Zz
 Rng.Delete   '         .Interior.ColorIndex = 37  '
 Set Rng = Nothing
[B]End Sub[/B]

PHP:

Sub Sxep(Rng As Range)
    Columns("e:E").Select
    Selection.Sort Key1:=Rng, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
End Sub

MinhK · 16/6/08

Chào anh SA_DQ
Tôi vừa test xong macro số ngẫu..
1- Code phân phối hoàn tòan đúng nhưng tai sao dừng lại ở 633 ?
8x7x6x5x4x3x2x1=8! cách phân phối :
2- Trọng tâm của bài là "bỏ hàm Concatenate() vào"(insert formulas) vào các cell từ K2 tới IT . Trong đó, Hàm Concatenate(a,b,c,d,e,f,g,h), với 8 biến số a,b,c,d,e,f,g,h đươc phân phối ngẫu nhiên không trùng lặp.
Xem formulas của các cell từ K2 tới IT trên sheet1
Sheet2 dùng ở đây, với dụng ý kiểm nghiệm sự trùng lăp xảy ra ở column(s) nào của sheet1. VD:
---> dòng 51 và 52 bị trùng lặp, tương ứng với column "Test 19" và "Test 144" ở Sheet1
---> dòng 139 và 140 bị trùng lặp, tương ứng với column "Test 150" và "Test 185" ở Sheet1,
Từ đó Delete 1 trong 2 (vì dụ cột Test 144 và Test 185 ) của Sheet1
Một lần nữa cảm ơn anh SA_DQ đã bỏ thới gian quý báu, tận tình giúp tôi trong chuyên đổi PRJ.WBT sang VBA (?)

MK

SA_DQ · 16/6/08

MinhK đã viết:
Chào anh SA_DQ
Tôi vừa test xong macro số ngẫu..
1- Code phân phối hoàn tòan đúng nhưng tai sao dừng lại ở 633 ?
8x7x6x5x4x3x2x1=8! cách phân phối : MK

Mình cho rằng bạn có thể tiếp tục lấy thêm các số ngẫu; Bằng cách:

PHP:

           For bD = 4 To 5 
                SCh3 = Mid(SCh1, 4, 5) 
                SCh3 = Left(SCh1, 3) & Mid(SCh3, bD, 6 - bD) & Left(SCh3, bD - 1) 
                Range("E" & [E999].End(xlUp).Row + 1) = SCh3 
            Next bD

Khai báo thêm 1 biến chuỗi nữa & :

Dim SCh As Byte
Khi đó các dòng trên sẽ được thêm & sửa như sau:

PHP:

           For bD = 4 To 5 
                SCh = Mid(SCh1, 4, 5) 
                SCh3 = Left(SCh1, 3) & Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1) 
                Range("E" & [E9999].End(xlUp).Row + 1) = SCh3 
'Them:'
                SCh3 = Mid(SCh1,2,2) & Left( SCh1, 1) & _
                         Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1) 
                Range("E" & [E9999].End(xlUp).Row + 1) = SCh3
' */* '  
            Next bD

Bạn sẽ có thêm vài trăm số ngẫu không trùng nữa.
Nhưng càng ngày, các số trùng nhau sẽ càng nhiều! Tất nhiên trong mảco trên, tác giả đã tác động đến các records trùng rồi, cụ thể là xóa đi 1 record.

MinhK · 16/6/08

Good morning anh HYen17
tôi thêm vào
'Them:'
SCh3 = Mid(SCh1,2,2) & Left( SCh1, 1) & _
Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1)
Range("E" & [E9999].End(xlUp).Row + 1) = SCh3
' */* '
như anh chi dẫn, nhưng khổ nỗi là chỉ cho ra tổ hơp gồm 4 số
HCD0
Anh có thể xem lại đoạn code trên
Cảm ơn anh.
Minh phải đi cày rồi.
MK

SA_DQ · 17/6/08

MinhK đã viết:
Good morning anh HYen17
tôi thêm vào
như anh chi dẫn, nhưng khổ nỗi là chỉ cho ra tổ hơp gồm 4 số
HCD0
Anh có thể xem lại đoạn code trên Cảm ơn anh.

Mình đoán tại sao nói chỉ là chuỗi gồm 4 chữ cái rồi:
Bạn chưa khai báo thêm biến SCh & gán giá trị cho biến này tại dòng lệnh

PHP:

  SCh = Mid(SCh1, 4, 5)

Dòng này thay cho dòng lệnh SCh3 = Mid(SCh1, 4, 5) trước đó!

MinhK · 18/6/08

Thân chào anh HYen17
Đúng như HYen17 chỉ ra thì:

Sub ToHop8()
Const StrC As String = "ABCDEFGH"
Dim bA As Byte, bB As Byte, bC As Byte, bD As Byte
Dim SChu As String, SCh0 As String, SCh1 As String, SCh3 As String, SCh As String

Const KT As String = ""

Range("e2:E900").Clear
For bA = 1 To 8
SChu = Mid(StrC, bA, 9 - bA) & Left(StrC, bA - 1)
Range("E" & [E999].End(xlUp).Row + 1) = SChu

For bB = 2 To 7
SCh0 = Mid(SChu, 2, 7)
SCh0 = Left(SChu, 1) & Mid(SCh0, bB, 8 - bB) & Left(SCh0, bB - 1)
Range("E" & [E999].End(xlUp).Row + 1) = SCh0
For bC = 3 To 6
SCh1 = Mid(SCh0, 3, 6)
SCh1 = Left(SCh0, 2) & Mid(SCh1, bC, 7 - bC) & Left(SCh1, bC - 1)
Range("E" & [E999].End(xlUp).Row + 1) = SCh1
For bD = 4 To 5
SCh = Mid(SCh1, 4, 5) ' them
SCh3 = Mid(SCh1, 4, 5)
SCh3 = Left(SCh1, 3) & Mid(SCh3, bD, 6 - bD) & Left(SCh3, bD - 1)
Range("E" & [E999].End(xlUp).Row + 1) = SCh3
'Them:'
SCh3 = Mid(SCh1, 2, 2) & Left(SCh1, 1) & _
Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1)
Range("E" & [E9999].End(xlUp).Row + 1) = SCh3
' */* '

Next bD
Next bC
Next bB
Next bA
SearchDuplicat
End Sub
Kiêm tra lai thì đúng là 8 số rồi.
Cám ơn anh / chị và mong HYen17 giúp nốt phần còn lại.
MK

SA_DQ · 18/6/08

1528 số không trùng : Đủ cho bạn chưa?!

Bài thay macro này vô cái cùng tên ở #10 & chúc vui!

(Thêm nửa thì bạn tự ên, nha!)

PHP:

Option Explicit

Sub ToHop8()
 Const StrC As String = "ABCDEFGH"
 Dim bA As Byte, bB As Byte, bC As Byte, bD As Byte
 Dim SChu As String, SCh0 As String, SCh1 As String
 Dim SCh3 As String, SCh As String
 
 Application.ScreenUpdating = False
 Sheet2.Select:                         Range("e2:E2900").Clear
 For bA = 1 To 8
    SChu = Mid(StrC, bA, 9 - bA) & Left(StrC, bA - 1)
    Range("E" & [e1999].End(xlUp).Row + 1) = SChu
    
    For bB = 2 To 7
        SCh0 = Mid(SChu, 2, 7)
        SCh0 = Left(SChu, 1) & Mid(SCh0, bB, 8 - bB) & Left(SCh0, bB - 1)
        Range("E" & [e1999].End(xlUp).Row + 1) = SCh0
        For bC = 3 To 6
            SCh1 = Mid(SCh0, 3, 6)
            SCh1 = Left(SCh0, 2) & Mid(SCh1, bC, 7 - bC) & Left(SCh1, bC - 1)
            Range("E" & [e1999].End(xlUp).Row + 1) = SCh1
            For bD = 4 To 5
                SCh = Mid(SCh1, 4, 5)  
                SCh3 = Left(SCh1, 3) & Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1)
                Range("E" & [e1999].End(xlUp).Row + 1) = SCh3
'*'
                SCh3 = Mid(SCh, bD, 6 - bD) & Left(SCh, bD - 1) & Left(SCh1, 3)
                Range("E" & [e1999].End(xlUp).Row + 1) = SCh3            '&'

                SCh3 = Mid(SCh1, 2, 2) & Left(SCh1, 1) & Mid(SCh, bD, 6 - bD) _
                    & Left(SCh, bD - 1)
                Range("E" & [e1999].End(xlUp).Row + 1) = SCh3
'**'
                SCh3 = Mid(SCh, bD, 6 - bD) _
                    & Left(SCh, bD - 1) & Mid(SCh1, 2, 2) & Left(SCh1, 1)
                Range("E" & [e1999].End(xlUp).Row + 1) = SCh3            '&&'

            Next bD
        Next bC
    Next bB
 Next bA
 For bD = 2 To 8
    Replace8 Cells(bD, 3), Cells(bD, 4)
 Next bD
 SearchDuplicat
End Sub

MinhK · 19/6/08

Hi anh DA_DQ

Hì hì, đã là con người ai cũng có lòng tham, nói chưa đủ thì thú nhân tội lỗi,
Với tôi thì ... thường im lăng

Đoạn sau:
For bD = 2 To 8
Replace8 Cells(bD, 3), Cells(bD, 4)
Next bD
SearchDuplicat

Có lẽ copy paste bi thiếu gì, mong anh xem lại.

Cảm ơn anh.

SA_DQ · 19/6/08

MinhK đã viết:
Hi anh DA_DQ

PHP:

For bD = 2 To 8 Replace8 Cells(bD, 3), Cells(bD, 4) Next bD SearchDuplicat End Sub

Hãy đọc kỹ hướng dẫn trước khi dùng:
Bài thay macro này vô cái cùng tên ở #10 & chúc vui!
Ở #10 mình đưa ra 3 macro

Bạn sẽ phải có các cái:
Replace8
SearchDuplicat
Để thằng này nó gọi;
Tựu chung vẫn phải dùng file mình đã bỏ vô #10 này!

Trong đó có cả việc thử nghiệm khi 2 trong 8 số í trùng nhau nữa.

MinhK · 21/6/08

Thân chào anh Sa_DQ

Bạn sẽ phải có các cái:
Replace8
SearchDuplicat

Tôi cũng cố gắng tìm mà không đươc may mắn, hay là anh post lại cái Replace8 cho tôi đươc không?
Cảm ơn anh trước.

SA_DQ · 21/6/08

MinhK đã viết:
Bạn sẽ phải có các cái:
Replace8
SearchDuplicat
Tôi cũng cố gắng tìm mà không đươc may mắn, hay là anh post lại cái Replace8 cho tôi đươc không?

2ủa tình mình phải xin lỗi bạn, vì cái đó mình viết thêm mà chưa gởi lên;
Nó là đây:

PHP:

Sub Replace8(rWhat As String, dReplace As Variant)
    Columns("E:E").Select
    Selection.Replace What:=rWhat, Replacement:=dReplace, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True
End Sub

Bạn chép nó đến chổ mấy cái trên là được.

Lần nữa hết sức xin lỗi bạn! +-+-+-+

Chọn ngẫu nhiên theo

Thành viên mới

File đính kèm

Thành viên mới

File đính kèm

Po_pikachu@ymail.com

Thành viên mới

/(hông là gì!

Thành viên mới

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

Đếm ngược thời gian