Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
Dim sh1 As Object
Dim n As Integer
Dim k As Integer
If sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Workbooks.Open (ThisWorkbook.Path & "\价格表.xls")
Set sh1 = Workbooks("价格表.xls").Sheets("sheet1")
For n = 2 To 7
If sh1.Range("a" & n) = sh.Range("E5") Then
k = sh1.Range("b" & n)
Exit For
End If
Next n
Workbooks("价格表.xls").Close
If k = 0 Then
sh.Range("E7") = "查找不到"
Else
sh.Range("E7") = k
End If
End If
End Sub
VBA学习小组B组 B06 liuho1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim mbook As Workbook
Dim x As Integer
If Target.Address = "$E$5" Then
Set mbook = Workbooks.Open(ThisWorkbook.Path & "\价格表.xls")
With mbook.Sheets("Sheet1")
For x = 2 To 7
If .Cells(x, 1) = Range("E5") Then
Range("E7") = .Cells(x, 2)
Exit For
Else
Range("E7") = "查找不到"
End If
Next
End With
mbook.Close savechanges:=False
Set mbook = Nothing
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim I As Integer
If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Workbooks.Open ThisWorkbook.Path & "/价格表.xls"
ThisWorkbook.Activate
For I = 1 To 7
If Workbooks("价格表.xls").Sheets("Sheet1").Range("A" & I) = Workbooks("练习题.xls").Sheets("Sheet1").Range("e5") Then
Workbooks("练习题.xls").Sheets("Sheet1").Range("e7") = Workbooks("价格表.XLS").Sheets("Sheet1").Range("b" & I)
Exit Sub
End If
Next
Workbooks("练习题.xls").Sheets("Sheet1").Range("e7") = "查找不到"
End If
End Sub
A01:xxjjdd0000
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim x As Integer
Dim mysht As Worksheet, sht As Worksheet
Application.ScreenUpdating = False
If Target.Address <> "$E$5" Then Exit Sub
Workbooks.Open "E:\VBA入门基础（第二版）\兰校长入门讲课\第8课作业题查找\价格表.xls"
For x = 7 To 2 Step -1
Set sht = Workbooks("练习题.xls").Sheets("sheet1")
Set mysht = Workbooks("价格表.xls").Sheets("sheet1")
If sht.Range("E5") Like mysht.Range("a" & x) Then
sht.Range("E7") = mysht.Range("b" & x)
Exit For
End If
Next
If sht.Range("E5") <> mysht.Range("a" & x) Then
sht.Range("E7") = "查找不到"
End If
Workbooks("价格表.xls").Close
Application.ScreenUpdating = True
End Sub
F18:寂寞深水鱼
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
Dim wb As Workbook
Dim X As Integer, k As Integer
If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "/价格表.xls")
For X = 2 To 7
If wb.Sheets("sheet1").Cells(X, 1) = ThisWorkbook.Worksheets("sheet1").Range("e5") Then
k = wb.Sheets("sheet1").Cells(X, 2)
End If
Next X
wb.Close
If k = 0 Then
Range("e7") = "查找不到"
Else
Range("e7") = k
End If
End If
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim CP As Range
Dim DJ As Range
Set CP = Range("E5")
Set DJ = Range("E7")
If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Workbooks.Open ThisWorkbook.Path & "\价格表.xls"
Dim X%
For X = 2 To 7
If CP = Range("A" & X) Then
DJ = Range("B" & X)
Exit For
Else
DJ = "查找不到"
End If
Next X
Workbooks.Open(ThisWorkbook.Path & "\价格表.xls").Close
End If
End Sub
校长我来交作业了
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim JJB As Workbook
If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Set JJB = Workbooks.Open(ThisWorkbook.Path & "/价格表.xls")
Dim x As Integer
Dim dj
For x = 2 To 7
If Target.Value = Cells(x, 1) Then
dj = Cells(x, 2)
Target.Offset(2, 0).Value = dj
'MsgBox (dj)
Exit For
Else
Target.Offset(2, 0).Value = "查找不到"
End If
Next x
JJB.Close
End If
End Sub
如果是我设计程序，我不会打开价格表。
另外我喜欢设计价格查询窗体或是列表来处理这样的问题？请老师指点！