准提部林

在〔輸入表〕輸入完成後，再派出結果至〔報表〕，
做了幾個防呆，參考看看：

1. Sub 派出結果()
   
2. Dim Arr, A, T$, xD, DT As Range
   
3. Set DT = [H22]
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. Arr = Range([Database!B2], [Database!B65536].End(xlUp)(2))
   
6. For Each A In Arr
   
7. 　　T = Right(A, 7): If T Like "#######" Then xD(T) = 1
   
8. Next
   
9. If xD.Count = 0 Then MsgBox "Database無資料可作業！": Exit Sub
   
10. 　
    
11. Dim FL$, xB As Workbook, xS As Worksheet, R&
    
12. FL = ThisWorkbook.Path & "\範例報表.xls"
    
13. If Dir(FL) = "" Then MsgBox "找不到報表檔！": Exit Sub
    
14. If CheckBookOpen(FL) > 0 Then
    
15. 　　MsgBox "報表檔正被開啟中，為避免錯誤，請先關閉！": Exit Sub
    
16. End If
    
17. 　
    
18. Set xB = Workbooks.Open(FL)
    
19. With xB.Sheets(1)
    
20. 　　R = .[B65536].End(xlUp).Row
    
21. 　　If R < 7 Then MsgBox "報表無 MONBR 資料！": Exit Sub
    
22. 　　Arr = .Range("B7:B" & R)
    
23. 　　For i = 1 To UBound(Arr)
    
24. 　　　　T = Right(Arr(i, 1), 7): Arr(i, 1) = ""
    
25. 　　　　If xD(T) = 1 Then Arr(i, 1) = "V"
    
26. 　　Next i
    
27. 　　With .Range("N7:N" & R): .Value = Arr: .Select: End With
    
28. End With
    
29. 　
    
30. DT(2) = DT: DT = Now
    
31. MsgBox "派出結果至報表已完成，確定無誤後儲存再關閉檔案！":
    
32. End Sub
    
33. 　
    
34. '＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
    
35. Private Function CheckBookOpen(BookName$) As Long　'副程式-檢查檔案是否開啟中
    
36. On Error Resume Next
    
37. Open BookName For Binary Access Write Lock Write As #1
    
38. Close #1
    
39. CheckBookOpen = Err.Number
    
40. On Error GoTo 0
    
41. End Function

複製代碼

附件下載：
報表v01.rar (381.29 KB)

下載次數: 9

2015-9-24 11:43

准提部林

回復 4# v03586


用這下載吧：
http://www.funp.net/573395

多加點油，無法下載附件很不方便，不好意思老用其它的下載空間，得顧慮論壇的運作！