统计VBA学习小组正式组第八课（第九讲）的积分帖之作业上交贴（第10周）

冠军欧洲2010

说明:
统计帖每个学员只能跟帖回复一次，也就是在原来回复楼层的基础上点编缉，不要一个链接一层楼，否则不计算积分。
各小组学员上交作业时，一定要点击“我要参加”，并注明自己的新组编号和论坛ID，如果点击过“我要参加”但没有跟帖提交作业的，扣该学员5积分；如果跟帖提交了作业，但没有点“我要参加”的，不给予评分。

请各学员看清上面的说明，免得被扣了分分！
本帖为仅楼主可见帖，直接回复即可！

第八课（第九讲）作业链接：
http://www.excelpx.com/thread-224709-1-1.html

yu20078

[hide
]Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook, sh As Worksheet, rng As Range
Set sh = ThisWorkbook.ActiveSheet
If sh.Name = "Sheet1" And Target.Address = "$E$5" Then
    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\价格表.xls")
    ThisWorkbook.Activate
    For Each rng In wb.Sheets("sheet1").Range("a1:a7")
            If rng = sh.Range("e5").Value Then
                sh.Range("e7") = rng.Offset(0, 1).Value
                wb.Close False
                Exit Sub
            End If
    Next rng
    sh.Range("e7") = "查找不到"
    wb.Close False
    Application.ScreenUpdating = True
End If
End Sub
[/hide]

hrpotter

C12:hrpotter
C12-hrpotter-第8课作业题查找.rar (11.21 KB, 下载次数: 42)

2012-2-29 09:10 上传

点击文件名下载附件

wenchduan

A组长:wenchduan

无聊的疯子

A03:无聊的疯子

zjcat35

E02:zjcat35   交作业      

从从容容

D03  从从容容

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim JGB As Workbook
    Dim i As Range
    Dim S As String
    If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Set JGB = Workbooks.Open(ThisWorkbook.Path & "/价格表.xls")
        For Each i In JGB.Sheets("sheet1").Range("a1:a12")
            If i = Target Then
                S = i.Offset(, 1)
                GoTo 100
            End If
        Next
        S = "查找不到"
    End If
100: JGB.Close
    Range("e7") = S
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

我不知道呀

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim i As Integer
    Dim arr
    Dim price As Object
    Set price = Workbooks.Open(ThisWorkbook.Path & "\价格表.xls")
    arr = Application.Transpose(price.Sheets("Sheet1").Range("a1:b7"))
    If sh.Name = "Sheet1" And Target.Address = "$E$5" Then
        For i = 1 To 7
            If arr(1, i) = Target.Value Then
                Workbooks("练习题.xls").Sheets("Sheet1").Range("e7") = arr(2, i)
                Exit For
            Else
                Workbooks("练习题.xls").Sheets("Sheet1").Range("e7") = "查找不到"
            End If
        Next
        price.Close
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

想飞的鸟

因为代码不好粘贴,所以上传附件,不知行不行

dsjohn

作业做完，请老师修改，谢谢！