Private Sub Worksheet_Change(ByVal Target As Range)
Dim xF As Range
Application.ScreenUpdating = False
If Target.Count > 2 Or Target.Column <> 2 Then End
Set xF = [摘要!a:a].Find(Target.Value, Lookat:=xlWhole)
If xF Is Nothing Then
MsgBox "找不到!"
工作表2.Cells(Target.Row, 3) = ""
'工作表2.Cells(Target.Row, 2) = "" '這行無作用
Exit Sub
Else
m1 = xF(2, 1)
工作表4.Cells(m1, 2).Copy 工作表2.Cells(Target.Row, 3)
End If
Application.ScreenUpdating = True
Set xF = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 2 Then Exit Sub
If Target.Row = 1 Then Exit Sub
If IsNumeric(Target.Value) = fasle Then Exit Sub
Set cn = CreateObject("adodb.connection")
Select Case Application.Version
Case Is < 12: cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; Data Source=" & ThisWorkbook.FullName
Case Else: cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; Data Source=" & ThisWorkbook.FullName
End Select
Sql = "select count(*) as ct from [摘要$a1:B] where 代號 = '" & Format(Target.Value, "000") & "'"
Set rs = cn.Execute(Sql)
Application.EnableEvents = False
If rs.getrows(, , "ct")(0, 0) = 1 Then '偵錯時 容易失效
Set rs = cn.Execute("select * from [摘要$a1:B] where 代號 = '" & Format(Target.Value, "000") & "'")
Cells(Target.Row, 2).CopyFromRecordset rs '.getrows '(,,array("代號","姓名"))
Else
Target.Value = ""
End If
Application.EnableEvents = True
cn.Close
Set cn = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xF As Range
Application.ScreenUpdating = False
If Target.Count > 2 Or Target.Column <> 2 Then End
Application.EnableEvents = False '讓觸發失效才不會連續觸發
Set xF = [摘要!a:a].Find(Target.Value, Lookat:=xlWhole)
If xF Is Nothing Then
MsgBox "找不到!"
工作表2.Cells(Target.Row, 3) = ""
工作表2.Cells(Target.Row, 2) = ""
'Exit Sub
Else
m1 = xF(2, 1)
工作表4.Cells(m1, 2).Copy 工作表2.Cells(Target.Row, 3)
End If
Application.ScreenUpdating = True
Set xF = Nothing
Application.EnableEvents = True '最後才讓觸發恢復
End Sub
發表於 2023-2-7 22:34
| 
