Private Sub Form_Load() Me.Hide Open App.Path & "\out.txt" For Output As #1
For i = 1 To 9 For ii = 0 To 9 For iii = 0 To 9 For iv = 0 To 9 ans = "" If i <> ii And i <> iii And i <> iv And ii <> iii And ii <> iv And iii <> iv Then ans = i & ii & iii & iv: Print #1, ans Next Next Next Next
Private Sub Form_Load() Dim ans As String Me.Hide Open App.Path & "\out.txt" For Output As #2
For i = 1 To 9 For j = 0 To 9 If i <> j Then For r = 0 To 9 If i <> r And j <> r Then For K = 0 To 9 If i <> K And j <> K And r <> K Then ans = i & j & r & K
Print #2, ans ans = "" End If Next End If Next End If Next Next
Me.Hide Open App.Path & "\out.txt" For Output As #2
For i = 1 To 9 For J = 0 To 9 If i <> J Then For r = 0 To 9 If i <> r And J <> r Then For K = 0 To 9 If i <> K And J <> K And r <> K Then
If (i = 1 Or i = 3 Or i = 5 Or i = 7) _ And (J = 1 Or J = 3 Or J = 5 Or J = 7) _ And (r = 1 Or r = 3 Or r = 5 Or r = 7) _ And (K = 1 Or K = 3 Or K = 5 Or K = 7) Then If (i = 1 And J <> 3 And r <> 5 And K <> 7) _ Or (J = 3 And i <> 1 And r <> 5 And K <> 7) _ Or (r = 5 And i <> 1 And J <> 3 And K <> 7) _ Or (K = 7 And i <> 1 And J <> 3 And r <> 5) Then ans = i & J & r & K Print #2, ans ans = "" End If End If
Private Sub Form_Load() Me.Hide Open App.Path & "\out.txt" For Output As #1
For i = 1 To 9 For j = 0 To 9 For m = 0 To 9 For n = 0 To 9 a = "" If i <> j And i <> m And i <> n And j <> m And j <> n And m <> n Then a = i & j & m & n: Print #1, a Next n Next m Next j Next i
Private Sub Form_Load() Me.Hide Open App.Path & "\out.txt" For Output As #1
Dim A, B
For i = 1 To 9 For ii = 0 To 9 For iii = 0 To 9 For iv = 0 To 9 A = 0 B = 0
Select Case i Case 1: A = A + 1 Case 3: B = B + 1 Case 5: B = B + 1 Case 7: B = B + 1 End Select
Select Case ii Case 1: B = B + 1 Case 3: A = A + 1 Case 5: B = B + 1 Case 7: B = B + 1 End Select
Select Case iii Case 1: B = B + 1 Case 3: B = B + 1 Case 5: A = A + 1 Case 7: B = B + 1 End Select
Select Case iv Case 1: B = B + 1 Case 3: B = B + 1 Case 5: B = B + 1 Case 7: A = A + 1 End Select ans = ""
If i <> ii And i <> iii And i <> iv And ii <> iii And ii <> iv And iii <> iv And A = 1 And B = 1 Then ans = i & ii & iii & iv: Print #1, ans & " " & A & "A" & B & "B" Next Next Next Next
Private Sub Form_Load() Me.Hide Open App.Path & "\out.txt" For Output As #1
chs = 1357
For i = 1000 To 9999 c = True a = checkA(chs, i) b = checkB(chs, i) c = checkC(i) If c <> False And a = 1 And b = 1 Then Print #1, i, a & "A" & b & "B" Next
Close End End Sub
Function checkA(a, b) Dim N, L ans = 0 For i = 1 To 4 L = Mid(a, i, 1) N = Mid(b, i, 1) If L = N Then ans = ans + 1 Next checkA = ans End Function
Function checkB(a, b) Dim N(4), L(4) ans = 0 For i = 1 To 4 L(i) = Mid(a, i, 1) N(i) = Mid(b, i, 1) Next For j = 1 To 4 Select Case N(j) Case L(1): If j <> 1 Then ans = ans + 1 Case L(2): If j <> 2 Then ans = ans + 1 Case L(3): If j <> 3 Then ans = ans + 1 Case L(4): If j <> 4 Then ans = ans + 1 End Select Next checkB = ans End Function
Function checkC(a) As Boolean Dim tmp(4)
For i = 1 To 4 tmp(i) = Mid(a, i, 1) Next ans = True For i = 1 To 4 For j = 4 To 1 Step -1 If tmp(i) = tmp(j) And i <> j Then ans = False Next Next If ans = False Then checkC = False Else checkC = True End Function
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #1
Dim tmp(4), ch As Boolean
For i = 1000 To 9999
ch = True
For k = 1 To 4
tmp(k) = Mid(i, k, 1)
Next
For k = 1 To 4
For m = 4 To 1 Step -1
If tmp(k) = tmp(m) And k <> m Then ch = False
Next
Next
If ch = True Then Print #1, i
Next
Close
End
End Sub
arro好，
回覆刪除程式正確，很好。
不過，這樣的練習，不容易聯想到排列組合去，
下一個人要寫的，(或是arro要再寫一次也行)，請用4層迴圈，第1層是1到9，其它3層是0到9，去組合成一個4位數，當然，這時候再看看這4層是不是都不同。
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #1
For i = 1 To 9
For ii = 0 To 9
For iii = 0 To 9
For iv = 0 To 9
ans = ""
If i <> ii And i <> iii And i <> iv And ii <> iii And ii <> iv And iii <> iv Then ans = i & ii & iii & iv: Print #1, ans
Next
Next
Next
Next
Close
End
End Sub
//-------
怪暴力而簡短的寫法
這樣寫好像不用動到頭腦 -.-
Private Sub Form_Load()
回覆刪除Dim ans As String
Me.Hide
Open App.Path & "\out.txt" For Output As #2
For i = 1 To 9
For j = 0 To 9
If i <> j Then
For r = 0 To 9
If i <> r And j <> r Then
For K = 0 To 9
If i <> K And j <> K And r <> K Then
ans = i & j & r & K
Print #2, ans
ans = ""
End If
Next
End If
Next
End If
Next
Next
Close #2
End
End Sub
arro,佑 好，
回覆刪除兩個程式都對，這的確是我想讓你們練習的方式。
這個程式的後續就是，猜數字。
想想，你們已經找出來的這些所有的不同數字的4位數。
試試看有那些是符合猜了「1357」得到1A1B的呢?
(別告訴我你們不會玩幾A幾B的數字遊戲?)
熊掌好，
回覆刪除在校慶有成果展
我就是以AB猜數的遊戲來進行
不過我添增了難度
有重複的數字
EX:
Ans:10095
N :50901
得到 1A4B
如此這般
老師出的題目似乎是倒推回去~來去試看看!!
似乎太複雜:D
回覆刪除Private Sub Form_Load()
Dim ans As String
Me.Hide
Open App.Path & "\out.txt" For Output As #2
For i = 1 To 9
For J = 0 To 9
If i <> J Then
For r = 0 To 9
If i <> r And J <> r Then
For K = 0 To 9
If i <> K And J <> K And r <> K Then
If (i = 1 Or i = 3 Or i = 5 Or i = 7) _
And (J = 1 Or J = 3 Or J = 5 Or J = 7) _
And (r = 1 Or r = 3 Or r = 5 Or r = 7) _
And (K = 1 Or K = 3 Or K = 5 Or K = 7) Then
If (i = 1 And J <> 3 And r <> 5 And K <> 7) _
Or (J = 3 And i <> 1 And r <> 5 And K <> 7) _
Or (r = 5 And i <> 1 And J <> 3 And K <> 7) _
Or (K = 7 And i <> 1 And J <> 3 And r <> 5) Then
ans = i & J & r & K
Print #2, ans
ans = ""
End If
End If
End If
Next
End If
Next
End If
Next
Next
Close #2
End
End Sub
佑好，
回覆刪除且不說你這題的正確與否，這樣寫只是針對這一組答案，沒什麼發展性。
寫兩個小函數去檢查幾A和幾B，例如
if whatA(1357,ans) = 1 and whatB(1357,ans)=1 then ...
...
function whatA(a,b)
....
whata=...
end function
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #1
For i = 1 To 9
For j = 0 To 9
For m = 0 To 9
For n = 0 To 9
a = ""
If i <> j And i <> m And i <> n And j <> m And j <> n And m <> n Then a = i & j & m & n: Print #1, a
Next n
Next m
Next j
Next i
Close #1
End
End Sub
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #1
Dim A, B
For i = 1 To 9
For ii = 0 To 9
For iii = 0 To 9
For iv = 0 To 9
A = 0
B = 0
Select Case i
Case 1: A = A + 1
Case 3: B = B + 1
Case 5: B = B + 1
Case 7: B = B + 1
End Select
Select Case ii
Case 1: B = B + 1
Case 3: A = A + 1
Case 5: B = B + 1
Case 7: B = B + 1
End Select
Select Case iii
Case 1: B = B + 1
Case 3: B = B + 1
Case 5: A = A + 1
Case 7: B = B + 1
End Select
Select Case iv
Case 1: B = B + 1
Case 3: B = B + 1
Case 5: B = B + 1
Case 7: A = A + 1
End Select
ans = ""
If i <> ii And i <> iii And i <> iv And ii <> iii And ii <> iv And iii <> iv And A = 1 And B = 1 Then ans = i & ii & iii & iv: Print #1, ans & " " & A & "A" & B & "B"
Next
Next
Next
Next
Close
End
End Sub
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #1
chs = 1357
For i = 1000 To 9999
c = True
a = checkA(chs, i)
b = checkB(chs, i)
c = checkC(i)
If c <> False And a = 1 And b = 1 Then Print #1, i, a & "A" & b & "B"
Next
Close
End
End Sub
Function checkA(a, b)
Dim N, L
ans = 0
For i = 1 To 4
L = Mid(a, i, 1)
N = Mid(b, i, 1)
If L = N Then ans = ans + 1
Next
checkA = ans
End Function
Function checkB(a, b)
Dim N(4), L(4)
ans = 0
For i = 1 To 4
L(i) = Mid(a, i, 1)
N(i) = Mid(b, i, 1)
Next
For j = 1 To 4
Select Case N(j)
Case L(1): If j <> 1 Then ans = ans + 1
Case L(2): If j <> 2 Then ans = ans + 1
Case L(3): If j <> 3 Then ans = ans + 1
Case L(4): If j <> 4 Then ans = ans + 1
End Select
Next
checkB = ans
End Function
Function checkC(a) As Boolean
Dim tmp(4)
For i = 1 To 4
tmp(i) = Mid(a, i, 1)
Next
ans = True
For i = 1 To 4
For j = 4 To 1 Step -1
If tmp(i) = tmp(j) And i <> j Then ans = False
Next
Next
If ans = False Then checkC = False Else checkC = True
End Function
//--------
其實兩個 FUNC 可以融合成一個
感覺我的 checkA 有點多此一舉
arro,緣尉好，
回覆刪除程式都OK。
有些function如果功能小小的，是容易覺得多餘，就當是練習囉。
但是，也是有好處的，功能小小的，不容易出錯，任務清楚分明。
Private Sub Form_Load()
回覆刪除Me.Hide
Open App.Path & "\out.txt" For Output As #2
Call A1("")
Close
End
End Sub
Sub A1(a)
Dim s
s = Split("0 1 2 3 4 5 6 7 8 9")
If Len(a) = 4 Then
If a > 1000 Then Print #2, a
Else
For i = 0 To 9
If InStr(a, s(i)) = 0 Then Call A1(a & s(i))
Next
End If
End Sub
2:01