返回列表 上一主題 發帖

省略Q2:S2補助儲存格

myleoyes

帖子
463 
主題
116 
精華
0 
積分
580 
點名
0  
作業系統
Vista 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2010-5-4 
最後登錄
2017-11-13 

論壇贊助勳章論壇榮譽勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-3-31 23:01 | 只看該作者

省略Q2:S2補助儲存格

各位前輩你們好!!
Sub 執行()
  Dim Rng As Range
  If MsgBox("您確定要執行嗎?", vbYesNo) = vbYes Then
       [G1] = "": ActiveWindow.ScrollColumn = 1
       ActiveWindow.SmallScroll ToRight:=4
    With ActiveSheet
        ActiveCell = ""
        Set Rng = ActiveCell.Offset(, 7)
        Rng = Date
Again:
    A = Application.InputBox("輸入數據", "      請輸入數據", Type:=1)
        If A = 0 Or A < 0 Then
           Cancel = True: GoTo Again
        Else
           Selection.Offset(, 8) = A
        End If
Again1:
    AA = Application.InputBox("輸入數字", "      請輸入數字", Type:=1)
        If AA = 0 Or AA < 0 Then
           Cancel = True:  GoTo Again1
        Else
           Selection.Offset(, 9) = AA
        End If
        With Rng.Cells(1, 4)
            For Each e In Array(1, 2, 3)
                With .Cells(1, e)
                    .FormulaR1C1 = Cells(1, .Column).FormulaR1C1
                    If e = 1 Then
                        ActiveCell.Offset(, 10).Select
                        [Q2].Copy
                        ActiveCell.Select
                        ActiveSheet.Paste
                    ElseIf e = 2 Then
                        ActiveCell.Offset(, 1).Select
                        [R2].Copy
                        ActiveCell.Select
                        ActiveSheet.Paste
                    ElseIf e = 3 Then
                        ActiveCell.Offset(, 1).Select
                        [S2].Copy
                        ActiveCell.Select
                        ActiveSheet.Paste
                    End If
                End With
            Next
        End With
     End With
         [G:S].EntireColumn.AutoFit
         清單
    ElseIf vbNo Then
       End
    End If
       [G1].Select
End Sub
         問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!

LeoV66-1.rar (16.2 KB)

收藏 分享

myleoyes

帖子
463 
主題
116 
精華
0 
積分
580 
點名
0  
作業系統
Vista 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2010-5-4 
最後登錄
2017-11-13 

論壇贊助勳章論壇榮譽勳章
2#
發表於 2013-4-2 21:56 | 只看該作者
回復 1# myleoyes
各位前輩你們好!!
        小弟突然想到這修改就可以省略Q2:S2補助儲存格如下
Sub 執行()
  Dim Rng As Range
  If MsgBox("您確定要執行嗎?", vbYesNo) = vbYes Then
       [G1] = "": ActiveWindow.ScrollColumn = 1
       ActiveWindow.SmallScroll ToRight:=4
    With ActiveSheet
        ActiveCell = ""
        Set Rng = ActiveCell.Offset(, 7)
        Rng = Date
Again:
    A = Application.InputBox("輸入數據", "      請輸入數據", Type:=1)
        If A = 0 Or A < 0 Then
           Cancel = True: GoTo Again
        Else
           Selection.Offset(, 8) = A
        End If
Again1:
    aa = Application.InputBox("輸入數字", "      請輸入數字", Type:=1)
        If aa = 0 Or aa < 0 Then
           Cancel = True:  GoTo Again1
        Else
           Selection.Offset(, 9) = aa
        End If
        With Rng.Cells(1, 4)
            For Each e In Array(1, 2, 3)
                With .Cells(1, e)
                    .FormulaR1C1 = Cells(1, .Column).FormulaR1C1
                    If e = 1 Then
                       ActiveCell.Offset(, 10).Select
                          If [N4] = "" Then
                             [Q4] = "=IF(N4="""","""",I4*O4*P4)"
                             [Q4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                             [Q4] = ""
                          ElseIf [N4] <> "" Then
                             [Q4] = "=IF(N4="""","""",I4*O4*P4)"
                             [Q4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                          End If
                    ElseIf e = 2 Then
                       ActiveCell.Offset(, 1).Select
                          If [N4] = "" Then
                             [R4] = "=IF(N4="""","""",Q4-L4)"
                             [R4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                             [R4] = ""
                          ElseIf [N4] <> "" Then
                             [R4] = "=IF(N4="""","""",Q4-L4)"
                             [R4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                          End If
                    ElseIf e = 3 Then
                       ActiveCell.Offset(, 1).Select
                          If [N4] = "" Then
                             [S4] = "=IF(N4="""","""",R4/(Q4-R4))"
                             [S4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                             [S4] = ""
                          ElseIf [N4] <> "" Then
                             [S4] = "=IF(N4="""","""",R4/(Q4-R4))"
                             [S4].Copy
                             ActiveCell.Select
                             ActiveSheet.Paste
                          End If
                    End If
                End With
            Next
        End With
     End With
         [G:S].EntireColumn.AutoFit
         清單
    ElseIf vbNo Then
       End
    End If
       [G1].Select
End Sub
       謝謝各位前輩!!

TOP

        靜思自在 : 盡多少本份，就得多少本事。
返回列表 上一主題