避免重複執行程式

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

論壇贊助勳章論壇榮譽勳章

16^#

發表於 2010-12-28 20:40 | 只看該作者

回復 15# GBKEE
GBKEE良師你好!
　　　良師!謝謝!已經可以應付主管的要求囉!
不好意思再浪費你寶貴的時間謝謝再三!!

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

15^#

發表於 2010-12-28 14:21 | 只看該作者

回復 14# myleoyes
還欠缺什麼?? 清填滿嗎?
自己可以試試加上清填滿的條件.

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

論壇贊助勳章論壇榮譽勳章

14^#

發表於 2010-12-27 21:18 | 只看該作者

回復 13# GBKEE
GBKEE良師你好!
　　　良師!謝謝!辛苦囉!謝謝再三!!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target(1), Range("A5:A152")) Is Nothing Then
      If Target(1) <> "" And Range("AB5") = "" And Range("AB8") = "" Then 填滿
End If
If Not Intersect(Target(1), Range("H1:I2,M1:M2")) Is Nothing Then
End If
      Select Case Target(1).Address(0, 0)
      Case "C1"
         If Range("AB5") = 1 Or Range("AB8") = 2 Then 清填滿
         Range("AB5") = ""
      Case "H1"
         HA
      Case "H2"
         HB
      Case "I1"
         IA
      Case "I2"
         IB
      Case "M1"
         MA
      Case "M2"
         MB
End Select
End Sub

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

13^#

發表於 2010-12-26 20:48 | 只看該作者

回復 12# myleoyes
是這樣嗎?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target(1), Range("A5:A152")) Is Nothing Then
If Target(1) <> "" And Range("AB5") = "" And Range("AB8") = "" Then 填滿
End If
If Not Intersect(Target(1), Range("H1:I2,M1:M2")) Is Nothing Then
If Range("AB5") = 1 Or Range("AB8") = 2 Then 清填滿
Range("AB5") = ""
Select Case Target(1).Address(0, 0)
Case "H1"
HA
Case "H2"
HB
Case "I1"
IA
Case "I2"
IB
Case "M1"
MA
Case "M2"
MB
End Select
End If
End Sub

複製代碼

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

論壇贊助勳章論壇榮譽勳章

12^#

發表於 2010-12-26 18:22 | 只看該作者

回復 10# myleoyes
GBKEE良師你好!
　　　良師!謝謝!不好意思..你可能有些誤解
         再附檔這是經過實際測試OK!的檔
         良師!其實你只要將找到位置與參照填滿
         合併就可以囉!因為找到位置的方式
         必須要在A欄作自訂格式,否則程式
         永遠只會找到AB6的位置不會找不到
         A欄的位置,辛苦囉!謝謝再三!!

Leov37-7.rar (19.59 KB)

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

11^#

發表於 2010-12-26 16:48 | 只看該作者

本帖最後由 GBKEE 於 2010-12-26 16:49 編輯

回復 10# myleoyes
自動填滿: ActiveCell 在A欄 ,是 "C:E,G:I,M:M" 等欄的填滿 .
手動填滿: 按鈕8A ,按鈕9A,按鈕10A 是各欄單獨的的填滿.
都依據 AB5:AB7 的數據來填滿的
這樣的說法對嗎?
請問數字填滿的等差數,都是依據 AB5的數字嗎?
標題3 差2位, 標題5 差1位,標題7 連續沒有一致規則性?

標題3	標題4	標題5	標題7
2	0.065	10
4	0.065	11	5
6	0.065	12	5

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

論壇贊助勳章論壇榮譽勳章

10^#

發表於 2010-12-26 15:53 | 只看該作者

回復 9# GBKEE
GBKEE良師你好!
　　　良師!謝謝!程式的想法有誤
         小弟如此比喻填滿分為手動(填滿)
         與自動(填滿)兩部份解釋
         當執行手動(填滿)時,加入Range("AB6") = ActiveCell
         這一行作為自動(填滿)開始列的參照位置
         加入Range("AB7") = ZZ
         這一行作為自動(填滿)間隔列數的參照數據
         加入Range("AB5") = 1
         這一行作為關閉手動(填滿)A欄的開關
         因為A欄是觸發點,所以要執行自動(填滿)必須關閉手動(填滿)
         因此只要手動(填滿)作任何動作,都會留下軌跡
         供自動(填滿)作依據,確保動作一致無誤
         所以要執行自動(填滿)就必須先找到A欄的位置
         如今良師將手動(填滿)與自動(填滿)兩部份
         合併為單一程式,所以執行手動(填滿)是OK!!
         但當按鈕9A時就凸槌囉!!因為你的程式
         Dim E&, i&, R As Range, T%, ZZ
         Range("AB6") = ActiveCell這一列依然存在
         所以AB6會將原來的數字變成按鈕9A
         因而失去功能如附檔請參考看看
         辛苦囉!謝謝再三!!

Leov37-6.rar (18.63 KB)

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2010-12-25 11:46 | 只看該作者

回復 8# myleoyes
是這樣嗎?

Sub 填滿()
Dim E&, i&, R As Range, T%,ZZ
Range("AB6") = ActiveCell
E = Cells(ActiveCell.Row, 1).End(xlDown).Row
Again:
ZZ = Application.InputBox("請輸入列數", "請輸入填滿間隔列數", 10, Type:=2)
If ZZ = "" Or ZZ = False Then End
Range("AB7") = ZZ
If ZZ <= 0 Then
MsgBox "列數間隔不得小於１列！！！", , "列數錯誤請重新輸入！！"
GoTo Again
End If
Range("AB5") = 1
Application.EnableEvents = False
For i = ActiveCell.Row To E
For Each R In Range("c:e,g:i,m:m").Columns
T = IIf(i + ZZ <= E, ZZ + 1, E - i + 1)
If Mid(R.Cells(i).Formula, 1, 1) = "=" Then
R.Cells(i).AutoFill R.Cells(i).Resize(T)
Else
R.Cells(i).Offset(-1).Resize(2).AutoFill R.Cells(i).Offset(-1).Resize(T + 1)
End If
Next
Cells(i, 1).Resize(, 15).Interior.ColorIndex = 34
i = i + ZZ - 1
Next
Application.EnableEvents = True
End Sub

複製代碼

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

論壇贊助勳章論壇榮譽勳章

8^#

發表於 2010-12-25 09:41 | 只看該作者

回復 7# luhpro
luhpro前輩你好!
      前輩!非常感激謝謝!再附檔案
      Leov37-5,Leov37-51在2003應可以執行,將原填滿程式
      Sub 填滿()
         Dim E&, i&
         Range("AB6") = ActiveCell '加入這一行開始列的參照位置
         E = Cells(ActiveCell.Row, 1).End(xlDown).Row
      Again:
         ZZ = Application.InputBox("請輸入列數", "請輸入填滿間隔列數", 10, Type:=2)
         If ZZ = "" Or ZZ = False Then End
         Range("AB7") = ZZ '加入這一行間隔列數的參照數據
         If ZZ <= 0 Then
         MsgBox "列數間隔不得小於１列！！！", , "列數錯誤請重新輸入！！"
         GoTo Again
         End If
         For i = ActiveCell.Row To E Step ZZ
         With Cells(i, 1).Resize(, 15).Interior
         .ColorIndex = 34
      End With
         Next
         Range("AB5") = 1 '加入這一行A欄的參照開關
      End Sub
      所以當資料改完後執行參照填滿
      因為小弟能力不足,所以用拼湊的方式
      先找到位置再執行填滿,就能解決困擾的問題
      Sub IA()
         清除填滿
               HA
         MA
         參照填滿
         Range("I3").Select
         Range("I:I").EntireColumn.AutoFit
      End Sub
      Sub 參照填滿()
         Dim E&, i&
         找到位置
         E = Cells(ActiveCell.Row, 1).End(xlDown).Row
         For i = ActiveCell.Row To E Step Range("AB7")
         With Cells(i, 1).Resize(, 15).Interior
               .ColorIndex = 34
         End With
         Next
         Range("AB5:AB7") = ""
      End Sub
      Sub 找到位置()
         With Sheet1
         Set c = Range("AB6")
         Set Rng = .Cells.Find(Format(c, "0列"), LookIn:=xlValues, LookAt:=xlWhole)
               .Select
         If Not Rng Is Nothing Then Rng.Select
      End With
      End Sub
      只是原本應該不需要如此複雜
      無奈!!能力只有如此這般..!!
      前輩能否簡化程式嗎?
      希望有能力的前輩,請不吝賜教謝謝再三!!
      小弟在此順祝各位前輩!
            聖誕節快樂!!身體健康事事如意...

Leov37-5.rar (13.77 KB)

Leov37-51.rar (13.24 KB)