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
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 '恢復自動運算
