麻辣家族討論版版 - Powered by Discuz! Board

標題: 程式如何寫比較順暢快速 [打印本頁]

作者: myleoyes 時間: 2012-10-24 22:40 標題: 程式如何寫比較順暢快速

各位前輩你們好!
      前輩!!問題如附檔說明
      請知道的前輩,不吝賜教謝謝再三!!
Sub 練習()
With Sheets("練習")
   [AG3] = "=AB2-SUM(AD2/2,AE2,AA3,AC3/2)": [AI3] = "=AG3/(AA3+AC3/2)"
   .Range("V" & Rows.Count).End(xlUp)(2, 1).Select: Selection = Date: ActiveCell.Offset(0, 1).Select
   ZZ = Application.InputBox("請輸入數字", "練習資料", Type:=1)
   If ZZ <= 0 Then ActiveCell.Offset(0, -1) = "": [AG3,AI3] = "": End
   ActiveCell = ZZ: ActiveCell.Font.ColorIndex = 7: ActiveCell.Offset(0, 1).Select
ag:
   ZZ = Application.InputBox("請輸入數字", "數據資料", Type:=1)
   If ZZ <= 0 Then GoTo ag
   ActiveCell = ZZ: ActiveCell.Offset(0, 2).Select
   [Z3:AI3].Copy: ActiveSheet.Paste: Calculate: [AG3,AI3] = "": Application.CutCopyMode = False
   ActiveCell.Offset(, 2) = "": ActiveCell.Offset(, 4) = "": ActiveCell.Offset(, 5) = "": ActiveCell.Offset(, 8) = ""
   .Range("AC" & Rows.Count).End(xlUp).Select
   If Selection <= 150 Then Selection = 200: ActiveCell.Font.ColorIndex = 7
   .Range("AG" & Rows.Count).End(xlUp).Select: ActiveCell.Font.ColorIndex = 10
   .Range("AI" & Rows.Count).End(xlUp).Select
   If Selection < 0 Then ActiveCell.Font.ColorIndex = 3
: Calculate: .Columns("V:AI").EntireColumn.AutoFit
   End With
   ActiveWorkbook.Save
End Sub

作者: GBKEE 時間: 2012-10-25 08:13

回復 1# myleoyes
試試看

Sub 練習()
Dim Rng As Range
With Sheets("練習")
.[AG3] = "=AB2-SUM(AD2/2,AE2,AA3,AC3/2)": .[AI3] = "=AG3/(AA3+AC3/2)"
Set Rng = Sheets("練習").Range("V" & Rows.Count).End(xlUp)(2, 1)
Rng = Date
ZZ = Application.InputBox("請輸入數字", "練習資料", Type:=1)
If ZZ <= 0 Then Rng = "": .[AG3,AI3] = "": End
With Rng.Cells(1, 2) '由Rng的欄位算起第2欄同一列的儲存格 = W欄
.Value = ZZ
.Font.ColorIndex = 7
End With
ag:
ZZ = Application.InputBox("請輸入數字", "數據資料", Type:=1)
If ZZ <= 0 Then GoTo ag
With Rng.Cells(1, 3) '由Rng的欄位算起第3欄同一列的儲存格=X欄
.Value = ZZ
.Font.ColorIndex = 7
End With
With Rng.Cells(1, 5) '由Rng的欄位算起第4欄同一列的儲存格=Z欄
For Each e In Array(1, 2, 4, 8, 10) '陣列: 由Z欄算起的欄
With .Cells(1, e) '由Z欄算起的欄同一列的儲存格
.FormulaR1C1 = Cells(3, .Column).FormulaR1C1
If e = 4 And .Value <= 150 Then
.Value = 200
.Font.ColorIndex = 7
ElseIf e = 8 Then
.Font.ColorIndex = 10
ElseIf e = 10 And .Value < 0 Then
.Font.ColorIndex = 3
End If
End With
Next
End With
.Columns("V:AI").EntireColumn.AutoFit
'如活頁簿設定計算 :方式為手動,那才須重算此工作表.
.Calculate '重算此工作表.
'此重算也許是你認為執行起來覺得很慢的主因
End With
ActiveWorkbook.Save
End Sub

複製代碼

作者: myleoyes 時間: 2012-10-25 21:19

回復 2# GBKEE
良師!謝謝!程式OK! 下個範例再麻煩一下
   當儲存格解註內容的最後兩個字是配股
      程式就會改變儲存格的顏色
      例如D3解註=聯詠配股變顏色
            D4解註=聯詠配息不會變顏色
            D5解註=台積電配股也變顏色
      如何修改此程式才能合乎需求
Sub 股利所得()
Again:
ZZ = Application.InputBox("輸入金額", "請輸入股利收入", "10,000", Type:=1)
[A15] = ZZ
If ZZ > 10000000 Then [A15] = 10000000
If [A15] = False Then [A15] = "": End
If ZZ <= 5000 Then MsgBox "股利收入少於或等於5000不扣補充保費！！": [A15] = "": GoTo Again
[A15] = [A14] * [A15]
With Sheets("應扣額")
   .[A15].Copy .[D100].End(xlUp)(2, 1)
   .[D15:D100].Font.ColorIndex = 7
   .Range("D" & Rows.Count).End(xlUp).Select
   If ActiveCell.Comment Is Nothing Then ActiveCell.AddComment
   ZZ = InputBox("請輸入股票名稱與配息或配股", "解註", " 配息或配股", 0)
If ZZ = "" Then ActiveCell.Comment.Delete: Exit Sub
   ActiveCell.Comment.Text Text:=ZZ
   If ActiveCell.Comment.Text = "配股" Then ActiveCell.Font.ColorIndex = 5
   [A15] = "": [D15].Select
End With
End Sub
   良師!請再辛苦囉!謝謝再三!!

作者: GBKEE 時間: 2012-10-26 06:14

回復 3# myleoyes

If ActiveCell.Comment.Text Like "*配股*" Then ActiveCell.Font.ColorIndex = 5

複製代碼

作者: myleoyes 時間: 2012-10-26 21:48

回復 4# GBKEE
良師!謝謝!程式OK!不好意思這個範例再麻煩一下
Sub Ex()
         Selection = CDate(Application.Ceiling((DateSerial(Year(Date), 1, 1) - 7) / 7, 1) * 7 + 7
* 3)
         Selection.Offset(0, 1) = "=IF(ISNUMBER(MATCH(A1,EDATE(A22,{0,6,12})-(WEEKDAY(EDATE(A22,
{0,6,12}),2)-6),0)),""維修""&LOOKUP(A1,EDATE(A22,{0,6,12})-(WEEKDAY(EDATE(A22,{0,6,12}),2)-6),
{1,2,0})&""次"",INDEX(EDATE(A22,{12,6,0})-(WEEKDAY(EDATE(A22,{12,6,0}),2)-6),MATCH(A1,EDATE(A22,
{12,6,0})-(WEEKDAY(EDATE(A22,{12,6,0}),2)-6),-1)))"
         End Sub
      當點選A22時,程式在B22寫入=IF(ISNUMBER(MATCH(A1,EDATE(A22,{0,6,12})-....,-1)))公式
      但問題是當點選A25時,程式在B25寫入的還是"=IF(ISNUMBER(MATCH(A1,EDATE(A22,{0,6,12})-....,-
1)))"  公式
      也就是說 A22 並無法變成 A25
      不知有方式可以解決此難題
      請不吝賜教謝謝再三!!

作者: GBKEE 時間: 2012-10-27 06:57

回復 5# myleoyes
用R1C1 表示法
"=IF(ISNUMBER(MATCH(A1,EDATE(RC[-1],{0,6,12})-....,-"

作者: myleoyes 時間: 2012-10-27 21:25

回復 6# GBKEE
良師!謝謝!為何?按鈕會是錯誤訊息呢?
   =IF(ISNUMBER(MATCH('A1',EDATE(A24,{0,6,12})...
   A1為何變成'A1'
   如附檔所示
   請再麻煩指導謝謝再三!!辛苦囉!

作者: GBKEE 時間: 2012-10-28 06:55

回復 7# myleoyes

用R1C1 表示法"=IF(ISNUMBER(MATCH(A1,EDATE(RC[-1],{0,6,12})-....,-"

A1 沒改到
"=IF(ISNUMBER(MATCH(R1C1,EDATE(RC[-1],{0,6,12})-....,-"[/quote]

作者: c_c_lai 時間: 2012-10-28 07:44

回復 7# myleoyes
回復 8# GBKEE
Sub 維修()與Sub Ex() 正如 GBKEE 大大之修正後的結果：

Sub 維修()
Selection = CDate(Application.Ceiling((DateSerial(Year(Date), 1, 1) - 7) / 7, 1) * 7 + 7 * 3)
Selection.Offset(0, 1) = "=IF(ISNUMBER(MATCH(R1C1,EDATE(RC[-1],{0,6,12})-(WEEKDAY(EDATE(RC[-1],{0,6,12}),2)-6),0)),""維修""&LOOKUP(R1C1,EDATE(RC[-1],{0,6,12})-(WEEKDAY(EDATE(RC[-1],{0,6,12}),2)-6),{1,2,0})&""次"",INDEX(EDATE(RC[-1],{12,6,0})-(WEEKDAY(EDATE(RC[-1],{12,6,0}),2)-6),MATCH(R1C1,EDATE(RC[-1],{12,6,0})-(WEEKDAY(EDATE(RC[-1],{12,6,0}),2)-6),-1)))"
End Sub
Sub Ex()
Selection = CDate(Application.Ceiling((DateSerial(Year(Date), 1, 1) - 7) / 7, 1) * 7 + 7 * 3)
Selection.Offset(0, 1) = "=IF(ISNUMBER(MATCH(A1,EDATE(A22,{0,6,12})-(WEEKDAY(EDATE(A22,{0,6,12}),2)-6),0)),""維修""&LOOKUP(A1,EDATE(A22,{0,6,12})-(WEEKDAY(EDATE(A22,{0,6,12}),2)-6),{1,2,0})&""次"",INDEX(EDATE(A22,{12,6,0})-(WEEKDAY(EDATE(A22,{12,6,0}),2)-6),MATCH(A1,EDATE(A22,{12,6,0})-(WEEKDAY(EDATE(A22,{12,6,0}),2)-6),-1)))"
End Sub

複製代碼

[attach]12908[/attach]
GBKEE 大大，到目前為止，我也瞭解了 FormulaR1C1 的應用，謝謝您！

作者: c_c_lai 時間: 2012-10-28 08:12

回復 8# GBKEE
請教您為什麼Sub 維修()與Sub Ex()執行出來的結果值不一樣呢？
左邊完全是Sub Ex()執行出來的結果，右方則是兩者混合交錯執行。
[attach]12909[/attach]

作者: c_c_lai 時間: 2012-10-28 08:34

回復 8# GBKEE
補上檔案共參考：
[attach]12910[/attach]

作者: GBKEE 時間: 2012-10-28 09:17

回復 10# c_c_lai
看看工作表它的公式

Sub Ex()
[B5] = "=R[1]C[1]"
[B6] = "=C6"
[B7] = "=R[-1]C[1]"
[B8] = "=R6C3"
[B9] = "=$C$6"
End Sub

複製代碼

作者: myleoyes 時間: 2012-10-28 16:16

回復 8# GBKEE
前輩!非常謝謝指導...
良師!謝謝!原來如此!殆勢啦!又來一題
照你的指導畫葫蘆還是畫不出來
登入程式實在沒辦法
寫入程式勉強可以執行
執行結果如動畫所示
請再指導真的感恩謝謝再三!!
Sub 登入()
With Sheets("學習")
ag:
   ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=2)
   If ZZ = "" Then Selection = "": End
   If ZZ = False Then Selection = "": End
   .Range("N" & Rows.Count).End(xlUp)(2, 1).Select
   ActiveCell = ZZ: ActiveCell.Offset(0, 1) = [C5]
   ' 如果選取並非B欄資料  Then MsgBox "選取的資料並非B欄所有！！請重新選取": GoTo ag
ag1:
   ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=1)
   If ZZ = False Then 寫入: End
   .Range("N" & Rows.Count).End(xlUp)(2, 1).Select
   ActiveCell = ZZ: ActiveCell.Offset(0, 1) = [C7]
   ' 如果選取並非B欄資料  Then MsgBox "選取的資料並非B欄所有！！請重新選取": GoTo ag1
   GoTo ag1
End With
End Sub
Sub 寫入()
Dim Rng As Range
ag:
With Sheets("學習")
Set Rng = Sheets("學習").Range("U" & Rows.Count).End(xlUp)(2, 1)
   ZZ = Application.InputBox("請輸入數字", "數字", Type:=1)
   If ZZ <= 0 Then GoTo ag
      With Rng.Cells(1, -4)
         .Value = ZZ
         .NumberFormatLocal = "#,##0_ ;[紅色]-#,##0 "
         .Font.ColorIndex = 10
      End With
   End With
   With Sheets("學習")
   Set Rng = Sheets("學習").Range("N" & Rows.Count).End(xlUp)(1, 1)
   With Rng.Cells(1, 1)
         For Each R In Array(8)
            With .Cells(1, R)
                  .FormulaR1C1 = Cells(3, .Column).FormulaR1C1
                  If R = 8 Then
                     .Font.ColorIndex = 7
                     .NumberFormatLocal = "0.00%"
                  End If
            End With
            Next
         End With
Set Rng = Sheets("學習").Range("N" & Rows.Count).End(xlUp)(2, 1)
   With Rng.Cells(1, 1)
         For Each e In Array(1, 2, 3, 4, 5, 6, 8)
            With .Cells(1, e)
                  .FormulaR1C1 = Cells(4, .Column).FormulaR1C1
                  If e = 1 Then
                     .Font.ColorIndex = 1
                  ElseIf e = 3 Then
                     .Value = Date
                     .NumberFormat = "e/m/d"
                     .Font.ColorIndex = 5
                  ElseIf e = 8 Then
                     .Value = Date
                     .NumberFormatLocal = "#,##0_ ;[紅色]-#,##0 "
                  End If
            End With
         Next
      End With
With Sheets("學習")
Set Rng = Sheets("學習").Range("N" & Rows.Count).End(xlUp)(1, 1)
      ZZ = Application.InputBox("請輸入數據", "數據", Type:=1)
      If ZZ <= 0 Then Exit Sub
         With Rng.Cells(1, 7)
            .Value = ZZ
         End With
      End With
   .Columns("N:U").EntireColumn.AutoFit
End With
End Sub

作者: GBKEE 時間: 2012-10-28 20:45

回復 13# myleoyes
試試看

Sub 登入()
Dim ZZ As Range
On Error GoTo er:
With Sheets("學習")
Do
Set ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=8)
'InputBox 設為Range -> 按取消會有錯誤
If ZZ(1).Column <> 2 Then xMsg = "選擇必需是 ""B"" 欄"
Loop Until ZZ(1).Column = 2 'B欄
With .Range("N" & Rows.Count).End(xlUp)
.Cells(2, 1) = ZZ(1) '預防ZZ選多列,指定為ZZ的CELLS(1)
.Cells(2, 2) = ZZ.Cells(1, 2)
End With
End With
er:
Err.Clear
On Error GoTo 0
End Sub

複製代碼

作者: myleoyes 時間: 2012-10-28 22:54

回復 14# GBKEE
良師!謝謝!程式可以登入但無法寫入(也就是說沒有自動)
      小弟修改如下只是覺得提示對話框是可以省略
      以便加速處理資料不是嗎?僅供參考真的辛苦你囉!
      非常的感恩謝謝再三!!

作者: GBKEE 時間: 2012-10-29 07:11

回復 15# myleoyes

程式可以登入但無法寫入(也就是說沒有自動)
小弟修改如下只是覺得提示對話框是可以省略

要寫入什麼,這概念我一點都不了解,要如何省略對話框?

作者: myleoyes 時間: 2012-10-29 22:29

回復 16# GBKEE
良師!小弟又把你給弄迷糊歹勢啦!
本範例程式分為2部份
1,登入就是將B欄與C欄資料登入在N欄所指定的位置
2,寫入就是將N3:U4複製到B欄與C欄資料登入在N欄所指定的位置
   登入可單選與複選兩種
   原程式登入
ag:
   ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=2)
   因為Type:=2 所以If ZZ = "" Then Selection = "": End  程式接受
               If ZZ = False Then  Selection = "": End  程式接受
               If 選取並非B欄資料  Then MsgBox "選取的資料並非B欄所有！！請重新選取": GoTo ag
   也就是說當第一次按登入鈕是可以後悔的,所以選擇取消或空白來結束程式
   若選取B欄確定,程式將B欄與C欄資料登錄在N欄所指定的位置
   程式再次呼叫下面的對話框
ag1:
   ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=1)
   因為Type:=1 所以If ZZ = "" Then 程式不接受
               If 選取並非B欄資料  Then MsgBox "選取的資料並非B欄所有！！請重新選取": GoTo ag1
               如果選擇取消If ZZ = False Then 寫入: End
               呼叫寫入程式就完成所需的任務這就是單選登入
               若選取B欄確定,程式將B欄與C欄資料登錄在N欄所指定的位置
               因為GoTo ag1所以Type:=1的對話框可以重複的出現一直到
               選擇取消If ZZ = False Then 寫入: End
               呼叫寫入程式就完成所需的任務這就是複選登入
   然而對話框Type:=1或Type:=2都無法達成"選擇必需是 ""B"" 欄"之要求
   良師為了達成"選擇必需是 ""B"" 欄"之要求將登入程式改為
   Set ZZ = Application.InputBox("請在B欄中選取資料", "資料登入", Type:=8)
   ....
   On Error GoTo 0
   End Sub
   因為Type:=8 所以If ZZ = False Then  程式不接受
               若選取B欄確定,程式將B欄與C欄資料登錄在N欄所指定的位置
               程式到此為止,並沒有呼叫寫入程式就無法完成所需的任務
               所以必須再按寫入鈕才能完成所需的任務,這樣太麻煩!!
               程式可以登入但無法寫入(也就是說沒有自動)這句話的由來
               即便加入寫入程式也是單選登入的功能罷!!
   所以小弟加入 If MsgBox("請問你是否繼續選取資料！！", vbYesNo) = vbYes Then
         登入
   ElseIf vbNo Then 寫入
   End If
   以提示對話框解決複選與寫入的問題
   假如按登入10次就必需也按提示對話框10次
   所以覺得以良師的功力應該是可以省略這個提示對話框
   就可以完成所需的任務不是嗎?
   這就是小弟的概念...不善表達,長篇大論不知良師!
   是否了解..真不好意思謝謝再三!!

作者: GBKEE 時間: 2012-10-30 10:25

回復 17# myleoyes
你的想法是 :
登入可以指定多個B欄的數值,後執行寫入程式

Sub Ex()
Dim Rng As Range, ZZ As Range, A As String, Msg As Boolean
With Sheets("學習")
Set Rng = .Range("b3", .[b3].End(xlDown)) 'B欄的範圍
For Each ZZ In Selection '工作表:所選取儲存格的範圍
If Not Application.Intersect(Rng, ZZ) Is Nothing Then '判斷此物件代表兩個或多個範圍重疊的矩形範圍
Msg = True
A = IIf(A = "", ZZ.Address(0, 0), A & "," & ZZ.Address(0, 0))
End If
Next
If Msg = False Then
MsgBox "沒有選擇到B欄的數值...": Exit Sub
Else
If MsgBox("所選取資料 " & A & Chr(10) & "確定寫入 ...", vbYesNo) = vbNo Then Exit Sub
End If
For Each ZZ In Selection
If Not Application.Intersect(Rng, ZZ) Is Nothing Then
With .Range("N" & Rows.Count).End(xlUp)
.Cells(2, 1) = ZZ
.Cells(2, 2) = ZZ.Cells(1, 2)
End With
End If
Next
End With
寫入
End Sub

複製代碼

作者: myleoyes 時間: 2012-10-30 21:11

回復 18# GBKEE
良師!太感動囉!真的感恩...太厲害謝謝再三!!辛苦囉!!

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)