Sao mà nhiều thế hả bạn, có 4 bộ số thỏa mãn yêu cầu thôi mà !
Sub Chay()
a = Val(Left(Rnd() * 100, 1)) + 1
b = Val(Left(Rnd() * 100, 1)) + 1
e = Val(Left(Rnd() * 100, 1)) + 1
f = Val(Left(Rnd() * 100, 1)) + 1
If a >= 10 Or b >= 10 Or e >= 10 Or f >= 10 Or Cells(a, b) = "" Or Cells(e, f) = "" Then
Call Chay
Else
Range("E20").Value = Cells(a, b) & "-" & Cells(e, f) & "-" & Cells(a, b) & "-" & Cells(e, f)
End If
End Sub
Bạn hãy test thật kỹ trên file rồi hãy đưa code lên! Nếu ra được kết quả 4 bộ số thì OK
Sub Chay() k = 1 For i = 1 To 1000 a = Val(Left(Rnd() * 100, 1)) + 1 b = Val(Left(Rnd() * 100, 1)) + 1 e = Val(Left(Rnd() * 100, 1)) + 1 f = Val(Left(Rnd() * 100, 1)) + 1 If aPrivate Sub CommandButton1_Click()
k = 1
For x1 = 1 To 10
For y1 = 1 To 10
If Cells(x1, y1) <> "" Then
For x2 = x1 To 10
For y2 = y1 To 10
If Cells(x2, y2) <> "" Then
For x3 = x1 To 10
For y3 = y1 To 10
If Cells(x3, y3) <> "" Then
For x4 = x1 To 10
For y4 = y1 To 10
If Cells(x4, y4) <> "" Then
If (x1 = x2 And x3 = x4) And (y1 = y3 And y2 = y4) And x2 <> x3 And y3 <> y4 Then
Cells(k, 12) = Cells(x1, y1) & "-" & Cells(x2, y2) & "-" & Cells(x3, y3) & "-" & Cells(x4, y4)
k = k + 1
End If
End If
Next
Next
End If
Next
Next
End If
Next
Next
End If
Next
Next
End Sub
Sub Timso()
Dim Rng As Range, Cll As Range
Dim i As Long, j As Long, r As Long, Lcol As Long, Lrow As Long
Application.ScreenUpdating = False
Range("L2:L1000").ClearContents
Set Rng = Range("A1:J10")
Lcol = Rng.Columns.Count
Lrow = Rng.Rows.Count
r = 2
For Each Cll In Rng
If Cll <> "" Then
With Cll
For i = 1 To Lrow - .Row
For j = 1 To Lcol - .Column
If .Offset(, j) <> "" And .Offset(i, 0) <> "" And .Offset(i, j) <> "" Then
Cells(r, 12) = .Value & "-" & .Offset(, j) & "-" & .Offset(i, j) & "-" & .Offset(i, 0)
r = r + 1
End If
Next j
Next i
End With
End If
Next
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Search4Num()
Dim Rng As Range, Clls As Range: Const Noi As String = "-"
Dim Jj As Long, Ww As Long, Zz As Long, lCol As Long, lRow As Long
Application.ScreenUpdating = False
Set Rng = [A1].CurrentRegion: lRow = Rng.Rows.Count
lCol = Rng.Columns.Count: Range("L2:L" & (lRow * lCol)).Clear
Set Rng = Rng.SpecialCells(xlCellTypeConstants, 1)
Zz = 1
For Each Clls In Rng
With Clls
For Jj = 1 To lRow - .Row
For Ww = 1 To lCol - .Column
If .Offset(, Ww) <> "" And .Offset(Jj) <> "" And .Offset(Jj, Ww) <> "" Then
Zz = Zz + 1
Cells(Zz, 12) = .Value & Noi & .Offset(, Ww) & Noi _
& .Offset(Jj, Ww) & Noi & .Offset(Jj, 0)
Cells(Zz, 12).Interior.ColorIndex = 32 + (Zz Mod 24)
End If
Next Ww
Next Jj
End With
Next Clls: Set Rng = Nothing
End SubSub VuongChuNhat()
Dim ra, rb, ca, cb
Dim rd As Long, rc As Long, cd As Integer, cc As Integer, n As Integer
Dim r1 As Long, r2 As Long, c1 As Integer, c2 As Integer
rd = Selection.Row
rc = rd + Selection.Rows.Count - 1
cd = Selection.Column
cc = cd + Selection.Columns.Count - 1
n = rc + 1
Range(Cells(n, rd), Cells(n + 1000, cd)).ClearContents
For r1 = rd To rc - 1
For c1 = cd To cc - 1
For r2 = r1 + 1 To rc
For c2 = c1 + 1 To cc
ra = Cells(r1, c1)
rb = Cells(r2, c1)
ca = Cells(r1, c2)
cb = Cells(r2, c2)
If ra <> "" And rb <> "" And ca <> "" And cb <> "" Then
Cells(n, 1) = ra & "-" & rb & "-" & ca & "-" & cb
n = n + 1
End If
Next
Next
Next
Next
End SubOption Explicit: Option Base 1
Const GPE As String = "-"
Dim Jj As Long, Ww As Long, lCol As Long, lRow As Long
Function SearchNums(Rng As Range)
ReDim FAddress(Rng.Cells.Count, 1): Dim Clls As Range
Dim Zz As Integer
For Jj = 1 To Rng.Cells.Count
FAddress(Jj, 1) = GPE
Next Jj
lRow = Rng.Rows.Count: lCol = Rng.Columns.Count
' Set Rng = Rng.SpecialCells(xlCellTypeConstants, 1)
For Each Clls In Rng
With Clls
For Jj = 1 To lRow - .Row
For Ww = 1 To lCol - .Column
If .Offset(, Ww) <> "" And .Offset(Jj) <> "" And .Offset(Jj, Ww) <> "" _
And .Value <> "" Then
Zz = Zz + 1
FAddress(Zz, 1) = .Value & GPE & .Offset(, Ww) & GPE _
& .Offset(Jj, Ww) & GPE & .Offset(Jj)
End If
Next Ww
Next Jj
End With
Next Clls
SearchNums = FAddress
End Function... If .Offset(, j) "" And .Offset(i, 0) "" And .Offset(i, j) "" Then Cells(r, 12) = .Value & "-" & .Offset(, j) & "-" & .Offset(i, j) & "-" & .Offset(i, 0) [COLOR=red]temp = temp & Cells(r, 12) & Chr(13)[/COLOR] r = r + 1 End If ... Application.ScreenUpdating = True [COLOR=red]MsgBox (temp) [/COLOR]End Sub
Sub Timso()
Dim Rng As Range, Cll As Range
Dim i As Long, j As Long, r As Long, Lcol As Long, Lrow As Long
Application.ScreenUpdating = False
Range("L2:L1000").ClearContents
Set Rng = Range("A1:J10")
Lcol = Rng.Columns.Count
Lrow = Rng.Rows.Count
r = 2
Dim Notice As String
Notice = "- KET QUA LA :"
For Each Cll In Rng
If Cll <> "" Then
With Cll
For i = 1 To Lrow - .Row
For j = 1 To Lcol - .Column
If .Offset(, j) <> "" And .Offset(i, 0) <> "" And .Offset(i, j) <> "" Then
Cells(r, 12) = .Value & "-" & .Offset(, j) & "-" & .Offset(i, j) & "-" & .Offset(i, 0)
Notice = Notice & Chr(13) & Cells(r, 12)
r = r + 1
End If
Next j
Next i
End With
End If
Next
MsgBox Notice
Set Rng = Nothing : Set Cll = Nothing
Application.ScreenUpdating = True
End Sub... If .Offset(, j) "" And .Offset(i, 0) "" And .Offset(i, j) "" Then [COLOR=red]temp = temp & [COLOR=blue]([/COLOR].Value & "-" & .Offset(, j) & "-" & .Offset(i, j) & "-" & .Offset(i, 0)[COLOR=blue])[/COLOR] & Chr(13) [/COLOR]r = r + 1 End If ....Option Explicit
Dim MyColor As Byte
Sub BaSoDinhTamGiac()
Const gN As String = "-"
Dim Hg As Byte: Dim Cot As Byte
Dim Rng As Range, Cll0 As Range, Cll2 As Range, sRng As Range
Set Rng = Range("A1:J10").SpecialCells(xlCellTypeConstants, 3)
Range("L1:L99").ClearContents
MyColor = [l2].Interior.ColorIndex + 1: If MyColor = 41 Then MyColor = 34
For Each Cll0 In Rng
Cot = Cll0.Column: Hg = Cll0.Row
If Hg = 10 Then GoTo GPE
Set sRng = Range(Cells(Hg + 1, 1), Cells(10, Cot))
For Each Cll2 In sRng
If Not Intersect(Cll2, Rng) Is Nothing And Not Intersect(Cells(Cll2.Row, _
Cot), Rng) Is Nothing And Cll2.Column < Cll0.Column Then
[l65500].End(xlUp).Offset(1) = Cll2.Value & gN & Cll0.Value _
& gN & Cells(Cll2.Row, Cot).Value
End If
Next Cll2
GPE: Next Cll0
Range("L2:l" & [l65500].End(xlUp).Row).Interior.ColorIndex = MyColor
End Sub
