- 帖子
- 14
- 主題
- 6
- 精華
- 0
- 積分
- 25
- 點名
- 0
- 作業系統
- Windows XP
- 軟體版本
- excel 2000
- 閱讀權限
- 10
- 註冊時間
- 2010-5-17
- 最後登錄
- 2023-3-24
|
[發問] 我的select case 為什麼執行起來像無窮迴圈??
請問各位先進，小弟想寫一個從選單儲存格選取後，依選取的人員各自進行一些處理，但不知為什麼trace時發現case區段內指令會一直重複執行，請教各位，謝謝~
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rowNo, colNo, countNo
Dim thisDate As String
Dim recStr As String
Dim sourceFile, backupFile
colNo = Selection.Columns.Column
rowNo = Selection.Rows.Row
thisDate = Str(Format(DateSerial(Year(Date), Month(Date), Day(Date)), "yyyymmdd"))
SetCurrentDirectoryA "\\econb\fs$\FS"
ChDir ".\資訊系統\系統測試"
If colNo = 2 Then '如果選定 測試人員(B)欄位
Select Case Selection.Value
Case "胡先生"
countNo = Application.WorksheetFunction.CountIf([B1:B300], "胡先生")
recStr = "H-" + thisDate + "-" + Str(countNo)
Call genRecFile("胡先生", recStr, rowNo, colNo)
Call callWord("胡先生", recStr)
Case "王小姐"
countNo = Application.WorksheetFunction.CountIf([B1:B300], "王小姐")
recStr = "W-" + thisDate + "-" + Str(countNo)
Call genRecFile("王小姐", recStr, rowNo, colNo)
Call callWord("王小姐", recStr)
Case "黃小姐"
countNo = Application.WorksheetFunction.CountIf([B1:B300], "黃小姐")
recStr = "F-" + thisDate + "-" + Str(countNo)
Call genRecFile("黃小姐", recStr, rowNo, colNo)
Call callWord("黃小姐", recStr)
Case Else
End Select
End If
'---------------------------------------------------------------------------------------------------------------
If colNo = 7 Then '如果選定 提交廠商 欄位
Dim fileStr As String
fileStr = Cells(rowNo, colNo - 3).Value & ".doc"
Dim fsApp As Object
Set fsApp = CreateObject("Scripting.FileSystemObject")
'
If Selection.Value = "提交" And Cells(rowNo, colNo - 3).Value <> "" Then '如果提交且紀錄編號不等於空白
'
fsApp.Movefile ".\測試報告\" & fileStr, ".\待提交\" '將word測試檔移到 待提交 目錄
'
Selection.Value = Selection.Value + "(" + thisDate + ")"
Range(Cells(rowNo, colNo - 2), Cells(rowNo, colNo - 2)).Hyperlinks(1).Address = ".\待提交\" + fileStr
ElseIf Selection.Value = "提交" And Cells(rowNo, colNo - 3).Value = "" Then
MsgBox "測試報告WORD檔不存在!!"
Selection.Value = ""
ElseIf Selection.Value = "取消提交" And Cells(rowNo, colNo - 3).Value = "" Then
MsgBox "測試報告WORD檔不存在!!"
Selection.Value = ""
ElseIf Selection.Value = "取消提交" And Cells(rowNo, colNo - 3).Value <> "" Then
fsApp.Movefile ".\待提交\" & fileStr, ".\測試報告\" '將WORD檔 移回原目錄
Range(Cells(rowNo, colNo - 2), Cells(rowNo, colNo - 2)).Hyperlinks(1).Address = ".\測試報告\" + fileStr
Else
End If
Set fsApp = Nothing
End If
End Sub
Sub genRecFile(Name As String, ByVal recStr As String, ByVal rowNo, ByVal colNo)
Cells(rowNo, colNo + 2) = recStr '記錄編號 欄位
Cells(rowNo, colNo + 3).Select '開啟 測試報告 欄位
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=".\測試報告\系統測試異常報告空白表單.doc" _
, TextToDisplay:="開啟"
sourceFile = ".\測試報告\系統測試異常報告空白表單.doc"
backupFile = ".\測試報告\" + recStr + ".doc"
FileCopy sourceFile, backupFile
Selection.Hyperlinks(1).Address = ".\測試報告\" + recStr + ".doc" '設定 開啟 超連結
Cells(rowNo, colNo + 1).Value = DateSerial(Year(Date), Month(Date), Day(Date))
End Sub
Sub callWord(Name As String, ByVal recStr As String)
Dim WDAPP As Word.Application
Set WDAPP = CreateObject("Word.Application")
'Set WDDOC = GetObject(".\測試報告\" & recStr + ".DOC")
WDAPP.Documents.Open "I:\資訊系統\系統測試\測試報告\" & recStr + ".DOC"
WDAPP.Visible = True
'Selection.Goto What:=wdGoToBookmark, Name:="recNo"
'Selection.TypeText Text:=recStr '在游標處打字
'Selection.Paste
''Selection.TypeParagraph '新增一行
'WDDOC.Save '儲存回原檔案(擇一選用即可)
''WDDOC.SaveAs "E:/ANY/COSMOS.DOC" '本行為另存新檔
WDAPP.Quit '本行為操作完畢自動關掉WORD的功能
Set WDAPP = Nothing |
|
發表於 2010-7-22 17:47
| 
發表於 2010-7-22 18:49
| 
