[發問] 有關巨集中迴圈的問題...

lincsn

我的問題：
(1) 跑出來為什麼會有空白列？(EX:我的D1=5,D2=7，此時若同時滿足D1跟D2時會多一行空排列，當條件設定三個且都滿足時，會多兩行空排列)
(2)最後一列無法被判斷，因此就算條件不符合還是會跑出來，有什麼解決方法嗎？
(3)迴圈很多，跑起來有點慢，有更快速的方法嗎？

附上程式碼：

1. Sub Lottery()
   
2. 
   
3.   Dim B1, B2, B3 As Integer
   
4.   Dim BALL As Integer
   
5.   Dim Row As Long
   
6.   Dim i As Integer
   
7.   
   
8.   BALL = 49
   
9.   Row = 1
   
10. 
    
11. 
    
12.         For B1 = 1 To BALL - 2
    
13. 
    
14.           For B2 = B1 + 1 To BALL - 1
    
15. 
    
16.             For B3 = B2 + 1 To BALL
    
17.                
    
18.                 ActiveSheet.Cells(Row, 1).Value = B1
    
19.                 ActiveSheet.Cells(Row, 2).Value = B2
    
20.                 ActiveSheet.Cells(Row, 3).Value = B3
    
21.                
    
22.                 For i = 1 To 49
    
23.                 If B1 = ActiveSheet.Cells(i, 4).Value _
    
24.                 Or B2 = ActiveSheet.Cells(i, 4).Value _
    
25.                 Or B3 = ActiveSheet.Cells(i, 4).Value Then Row = Row + 1
    
26.                 Next i
    
27.                
    
28. 
    
29.             Next B3
    
30. 
    
31.           Next B2
    
32. 
    
33.         Next B1
    
34. 
    
35. End Sub

複製代碼

附件：
text.rar (93.76 KB)

text
下載次數: 8

2011-7-3 01:08

如果有說明不清楚的地方，再麻煩跟小弟說聲～感激不盡XD

oobird

以你的思路，可以稍加改變：

1. Sub Lottery()
   
2.     Dim B1%, B2%, B3%, ball%, m&
   
3.     Dim arr()
   
4.     ball = 49
   
5.     For B1 = 1 To ball - 2
   
6.         For B2 = B1 + 1 To ball - 1
   
7.             For B3 = B2 + 1 To ball
   
8.                 m = m + 1
   
9.                 ReDim Preserve arr(1 To 3, 1 To m)
   
10.                 arr(1, m) = B1
    
11.                 arr(2, m) = B2
    
12.                 arr(3, m) = B3
    
13.             Next B3, B2, B1
    
14.             ActiveSheet.[a1].Resize(m, 3) = Application.Transpose(arr)
    
15.         End Sub

複製代碼

GBKEE

Dim B1, B2, B3 As Integer
上面的變數宣告中, B1, B2 的型態是 Variant, 只有B3 的型態是 Integer
http://forum.twbts.com/thread-4009-1-1.html

lincsn

回復 2# oobird


感謝oobird ^^
修改完後執行速度差超多！想請問這是什麼原理改變他的運行速度呢？
另外，

1.                 For i = 1 To 49
   
2. 
   
3.                 If B1 = ActiveSheet.Cells(i, 4).Value _
   
4. 
   
5.                 Or B2 = ActiveSheet.Cells(i, 4).Value _
   
6. 
   
7.                 Or B3 = ActiveSheet.Cells(i, 4).Value Then Row = Row + 1
   
8. 
   
9.                 Next i

複製代碼

我的判別式如果要加進去，該如何做修正？
這個判別式的目的：（篩選出我需要的數值）
Ex:
當我在D欄輸入：D1=3,D2=5,D3=7時,程式執行結果會是：
A1=1,B1=2,C1=3
A2=1,B2=2,C2=5
A3=1,B3=2,C3=7
.
.
.
A3244=7,B3244=48,C3244=49
也就是說我要如何在全部數值中，篩選出D欄中含有的數值？

再麻煩您了

lincsn

回復 3# GBKEE


感謝GBKEE~我瞭解您的意思了～
可是關於我的問題１，有什麼解決方案嗎？
我的判別式該如何做修正？

再麻煩您囉～

GBKEE

• 回復 5# lincsn
  是這樣嗎?
  修改 oobird版主的程式如下
  1. Sub Lottery()
     
  2.     Dim B1%, B2%, B3%, ball%, m&, P$
     
  3.     Dim arr()
     
  4.     ball = 49
     
  5.     With ActiveSheet
     
  6.         P = Join(Array(.[D1].Text, .[D2].Text, [D3].Text), ",")  '三個數字"00"的格式字串
     
  7.         For B1 = 1 To ball - 2
     
  8.             For B2 = B1 + 1 To ball - 1
     
  9.                 For B3 = B2 + 1 To ball
     
  10.                     If InStr(P, Format(B1, "00")) Or InStr(P, Format(B2, "00")) Or InStr(P, Format(B3, "00")) Then
      
  11.                         m = m + 1
      
  12.                         ReDim Preserve arr(1 To 3, 1 To m)
      
  13.                         arr(1, m) = B1
      
  14.                         arr(2, m) = B2
      
  15.                         arr(3, m) = B3
      
  16.                     End If
      
  17.         Next B3, B2, B1
      
  18.         ActiveSheet.[a1].Resize(m, 3) = Application.Transpose(arr)
      
  19.     End With
      
  20. End Sub

  複製代碼

資料輸入工作表  系統須處裡
1樓的程序中每次迴圈中有將資料輸入工作表
ActiveSheet.Cells(Row, 1).Value = B1
ActiveSheet.Cells(Row, 2).Value = B2
ActiveSheet.Cells(Row, 3).Value = B3
系統須處裡三次

速度會加快 :
ActiveSheet.[a1].Resize(m, 3) = Application.Transpose(arr)  
一次將資料輸入工作表  系統只須處裡一次

lincsn

回復 6# GBKEE


感謝GBKEE ！！
所以是利用矩陣來當暫存，之後一次把資料寫入～
這就是我要的結果^^

不過如果輸入的數值有可能到49個數值時，我剛試過把D1-D49全key進去可以跑出結果，不過針對這部份，有可能利用迴圈來完成嗎？

修改您的一部份程式如下：

1.         P = Join(Array(.[D1].Text, .[D2].Text, .[D3].Text, .[D4].Text, .[D5].Text, .[D6].Text, .[D7].Text _
   
2.        , .[D8].Text, .[D9].Text, .[D10].Text, .[D11].Text, .[D12].Text, .[D13].Text, .[D14].Text _
   
3.        , .[D15].Text, .[D16].Text, .[D17].Text, .[D18].Text, .[D19].Text, .[D20].Text, .[D21].Text _
   
4.        , .[D22].Text, .[D23].Text, .[D24].Text, .[D25].Text, .[D26].Text, .[D27].Text, .[D28].Text _
   
5.        , .[D29].Text, .[D30].Text, .[D31].Text, .[D32].Text, .[D33].Text, .[D34].Text, .[D35].Text _
   
6.        , .[D36].Text, .[D37].Text, .[D38].Text, .[D39].Text, .[D40].Text, .[D41].Text, .[D42].Text _
   
7.        , .[D43].Text, .[D44].Text, .[D45].Text, .[D46].Text, .[D47].Text, .[D48].Text, [D49].Text), ",")

複製代碼

再麻煩您囉^^"

GBKEE

回復 7# lincsn

1. Sub Ex()
   
2.     Dim R(), i%, P$
   
3.     R = [D1:D49].Value
   
4.     For i = 1 To UBound(R)
   
5.         R(i, 1) = Format(R(i, 1), "00")
   
6.     Next
   
7.     P = Join(Application.Transpose(R), ",")
   
8. End Sub

複製代碼

lincsn

回復 8# GBKEE


原來如此～感謝您！！:lol

linsurvey2005

這樣的互相學習
好刺激 好友啟發性
授用了~感謝(真是無價之寶)