- 帖子
- 124
- 主題
- 43
- 精華
- 0
- 積分
- 167
- 點名
- 0
- 作業系統
- Windows7
- 軟體版本
- office2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣台北
- 註冊時間
- 2011-3-16
- 最後登錄
- 2021-10-7
|
程式碼整合
平安
以下的程式碼是我用土法煉鋼的方式做的
目前正常運作中
請高手看看可否整合 ?
謝謝
Private Sub Worksheet_Change(ByVal Target As Range) '交互查詢
Application.Calculation = xlCalculationManual '關閉自動運算
ActiveSheet.Unprotect Password:=3551 '撤消工作表保護並取消密碼
Dim i%, x(), y(), xy()
Dim F1 As Range
Dim rn As Range, tt As Range
On Error Resume Next
Application.EnableEvents = False
With Sheets("廠商資料")
Set F1 = .Columns(1).Find([C3])
[c4] = .Cells(F1.Row, 2)
[c5] = .Cells(F1.Row, 7)
End With
Application.EnableEvents = True
Set T = Target
For Each tt In T
If tt.Column = 2 Then
Set rn = Sheet1.[c:c].Find(tt, , , 1)
If Not rn Is Nothing And tt.Offset(, 1) <> rn.Offset(, -1) Then
tt.Offset(, 1) = rn.Offset(, -1).Value
'tt.Offset(, 3) = rn.Offset(, 4).Value
' tt.Offset(, 6) = rn.Offset(, 1).Value
End If
ElseIf tt.Column = 3 Then
Set rn = Sheet1.[b:b].Find(tt, , , 1)
If Not rn Is Nothing And tt.Offset(, -1) <> rn.Offset(, 1) Then
tt.Offset(, -1) = rn.Offset(, 1).Value
' tt.Offset(, 2) = rn.Offset(, 5).Value
' tt.Offset(, 5) = rn.Offset(, 2).Value
End If
End If
Next tt
Set T = Nothing: Set tt = Nothing
Set U = Target
Set dbsheet = Sheets("天恩書目")
Set myrange = dbsheet.Range("c2:c2020")
For Each cell In U
rw = cell.Row '列
cl = cell.Column '欄
Select Case cl
Case 2, 3
If cell = "" And rw > 6 Then '品名被清空,不顯示
Application.EnableEvents = False
Range(Cells(rw, 7), Cells(rw, 16)).ClearContents
Application.EnableEvents = True
ElseIf cell <> "" And rw > 6 And cl = 2 Then '顯示資料,即顯示
Set m = myrange.Find(cell, LookIn:=xlValues)
Application.EnableEvents = False
If Not m Is Nothing Then
rw2 = m.Row
Cells(rw, 8) = dbsheet.Cells(rw2, 12)
Cells(rw, 9) = dbsheet.Cells(rw2, 14)
Cells(rw, 7) = dbsheet.Cells(rw2, 15)
Cells(rw, 10) = dbsheet.Cells(rw2, 19)
Cells(rw, 11) = dbsheet.Cells(rw2, 8)
Cells(rw, 12) = dbsheet.Cells(rw2, 23)
Cells(rw, 13) = dbsheet.Cells(rw2, 24)
Cells(rw, 14) = dbsheet.Cells(rw2, 29)
Cells(rw, 15) = dbsheet.Cells(rw2, 10)
Cells(rw, 16) = dbsheet.Cells(rw2, 11)
End If
Set U = Nothing
Application.EnableEvents = True
End If
Case 7, 8, 9, 10, 11, 12, 13, 14, 15, 16
If rw > 6 Then '修改資料
Set m = myrange.Find(Cells(rw, 2), LookIn:=xlValues)
Application.EnableEvents = False
If Not m Is Nothing Then
rw2 = m.Row
dbsheet.Cells(rw2, 12) = Cells(rw, 8)
dbsheet.Cells(rw2, 14) = Cells(rw, 9)
dbsheet.Cells(rw2, 15) = Cells(rw, 7)
dbsheet.Cells(rw2, 19) = Cells(rw, 10)
dbsheet.Cells(rw2, 8) = Cells(rw, 11)
dbsheet.Cells(rw2, 23) = Cells(rw, 12)
dbsheet.Cells(rw2, 24) = Cells(rw, 13)
dbsheet.Cells(rw2, 29) = Cells(rw, 14)
dbsheet.Cells(rw2, 10) = Cells(rw, 15)
dbsheet.Cells(rw2, 11) = Cells(rw, 16)
End If
dbsheet.Close
myrange.Quit
Set U = Nothing
Set dbsheet = Nothing
Set myrange = Nothing
Application.EnableEvents = True
End If
End Select
Next cell
On Error GoTo 1
Set V = Target
If V.Count > 1 Then End
If V.Address Like "*$A$2*" Then
x = Array("A", "B", "C")
y = Array("A倉庫", "B倉庫", "C倉庫")
If V = "進 貨 單" Or V = "贈 書 單" Or V = "發 行 者 取 書 單" Or V = "取 貨 單" Then
xy = x
Else
xy = y
End If
With [E7:E32].Validation
.Delete
.Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=Join(xy, ",")
End With
End If
dbsheet.Close
myrange.Quit
Set V = Nothing
Set dbsheet = Nothing
Set myrange = Nothing
Application.Calculate '恢復自動運算
Application.Calculation = xlCalculationAutomatic '恢復自動運算
Application.StatusBar = 就緒
Application.EnableEvents = True
1:
Set dbsheet = Nothing
Set myrange = Nothing
Application.Calculate '恢復自動運算
Application.Calculation = xlCalculationAutomatic '恢復自動運算
Application.StatusBar = 就緒
Application.EnableEvents = True
End Sub |
|
發表於 2014-4-11 10:20
| 
發表於 2014-4-11 13:53
| 