程式如何寫比較順暢快速

myleoyes

各位前輩你們好!
         前輩!!問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!
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

myleoyes

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

GBKEE

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

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

複製代碼

myleoyes

回復 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

回復 15# myleoyes

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

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

myleoyes

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

GBKEE

回復 13# myleoyes
試試看

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

複製代碼

myleoyes

回復 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

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

1. Sub Ex()
   
2.     [B5] = "=R[1]C[1]"
   
3.     [B6] = "=C6"
   
4.     [B7] = "=R[-1]C[1]"
   
5.     [B8] = "=R6C3"
   
6.     [B9] = "=$C$6"
   
7. End Sub

複製代碼

c_c_lai

回復 8# GBKEE
補上檔案共參考：
LeoV67.rar (9.62 KB)

下載次數: 5

2012-10-28 08:34