[已解决]求高手帮忙。。。

139079696

1.rar (9.42 KB, 下载次数: 6)

2013-4-20 00:05 上传

点击文件名下载附件

我把电脑考题复制进A列，B列能自动提取考题和题库搜索相应的答案显示出来，希望哪位大虾帮帮我

最佳答案

月排行榜 / 总排行榜

我不知道呀

2013-4-23 19:46

139079696 发表于 2013-4-23 00:40
不显示答案了。。。。其实很接近了，单选题能正常使用，就是多选题答案只显示最后一个，就差一点漏洞就能 ...

我测试过很正常，给你个附件，你点按钮看看吧！

跳转到最佳答案楼层

as0810114

将excel压缩后上传附件。

139079696

1.rar (9.42 KB, 下载次数: 14)

2013-4-19 22:56 上传

点击文件名下载附件
1

139079696

as0810114 发表于 2013-4-19 22:51
将excel压缩后上传附件。

1.rar (9.42 KB, 下载次数: 19)

2013-4-19 22:57 上传

点击文件名下载附件

我不知道呀

Sub tt()
Dim i As Integer
Dim j As Integer
Dim c As Range
For j = 1 To 66
If Sheets("题目输入区").Cells(j, 1).Value Like "[0-9]*" Then
  
    Sheets("题目输入区").Cells(j, 3) = Mid(Sheets("题目输入区").Cells(j, 1), InStr(1, Sheets("题目输入区").Cells(j, 1), " ") + 1, 100)
         
    With Worksheets("题库").Range("a1:a500")
    Set c = .Find(Sheets("题目输入区").Cells(j, 3).Value, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do   
                Sheets("题目输入区").Cells(j, 4) = Right(c, 1)   
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    End With

End If
Next j
End Sub

我不知道呀

Sub tt2()
    Dim i As Integer
    Dim j As Integer
    Dim c As Range
    For j = 1 To 66
        If Sheets("题目输入区").Cells(j, 1).Value Like "[0-9]*" Then
            Sheets("题目输入区").Cells(j, 3) = Mid(Sheets("题目输入区").Cells(j, 1), InStr(1, Sheets("题目输入区").Cells(j, 1), " ") + 1, 100)
            With Worksheets("题库").Range("a1:a500")
                Set c = .Find(Sheets("题目输入区").Cells(j, 3).Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        For i = 1 To Len(c)
                            If (Mid(c, i, 1) Like "[A-Z a-z ]") Then
                                Sheets("题目输入区").Cells(j, 4) = "答案" & Mid(c, i, 1)
                            End If
                        Next i
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With

        End If
    Next j
End Sub

139079696

我不知道呀 发表于 2013-4-20 11:58
Sub tt2()
    Dim i As Integer
    Dim j As Integer

VBA?.....,不会用，能不能麻烦你帮我弄进表格里，发复件给我，谢谢

139079696

我不知道呀 发表于 2013-4-20 11:58
Sub tt2()
    Dim i As Integer
    Dim j As Integer

谢谢，可以用了，不错，但有个问题
1、多选题显示答案会出问题，只显示一个答案
还有个问题，我想让答案显示在表格三“答案”对应的表格里，应该怎么弄吖。我想让答案看起来更直观

139079696

我不知道呀 发表于 2013-4-20 11:58
Sub tt2()
    Dim i As Integer
    Dim j As Integer

我需要你帮忙，谢谢，麻烦你了
1、多选题显示答案会出问题，只显示一个答案

我不知道呀

139079696 发表于 2013-4-21 23:26
我需要你帮忙，谢谢，麻烦你了
1、多选题显示答案会出问题，只显示一个答案

Sub tt2()
    Dim i As Integer
    Dim j As Integer
    Dim c As Range
    For j = 1 To 66
        If Sheets("题目输入区").Cells(j, 1).Value Like "[0-9]*" Then
            Sheets("题目输入区").Cells(j, 3) = Mid(Sheets("题目输入区").Cells(j, 1), InStr(1, Sheets("题目输入区").Cells(j, 1), " ") + 1, 100)
            With Worksheets("题库").Range("a1:a500")
                Set c = .Find(Sheets("题目输入区").Cells(j, 3).Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        For i = 1 To Len(c)
                            If (Mid(c, i, 1) Like "[A-Z a-z ]") Then
                                Sheets("题目输入区").Cells(j, 4) = Sheets("题目输入区").Cells(j, 4) & Mid(c, i, 1)
                            End If
                        Next i
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With

        End If
    Next j
’我在手机上回复你的，没有测试！你试试   

End Sub