查找到文字并在其后加excel单元格内的文字？

tsml

有下面一个程序，我怎么编也编不好，哪位老兄能帮我编一下，最好用VBA，拜谢了！！！

设有一个excel表name.xls如下，上行为姓名，下行为年龄，

     A          B       

1    张三   30         

2    李四   32

3    王五   34      

4    赵六   28

用鼠标在CAD中框中一些文字后，执行程序，就可以与excel表中的相比较，当文字中包含“王五”，该文字就变为“王五”  “34”(注意是在后面加一个字符串“34”，一共两个字符串) ，再接着找下一个被选中的文字重选与该表比较，找完为止。

以下是程序，编译通不过

---------------------------------------------------------------------

'比较CAD中选中的文字，如果与excel中指定列中某一单元格的文字相同，则在CAD中的该文字后加入excel该单元格同行不同列的另一单元格的文字
Sub getdata()
Dim sel As AcadSelectionSet
Dim i As Integer
Dim j As Integer
Dim start1 As Variant
Dim textObj As AcadText
Dim rows As Integer
Dim cols As Integer
Dim textString As String
Dim Height As Double

Height = 250
On Error Resume Next

'选择对象
Set sel = ThisDrawing.SelectionSets.Add("ssel")

If Err Then
    Err.Clear
    Set sel = ThisDrawing.SelectionSets.Item("ssel")
End If

On Error GoTo 0
sel.SelectOnScreen
Dim Ent As AcadEntity

Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")

If Err Then
    MsgBox " Excel 应用程序没有运行。请启动 Excel 并重新运行程序。"
    Exit Sub
End If

Dim xlSheet As Worksheet
Set xlSheet = xlApp.ActiveSheet

Dim xlRange As Range
Debug.Print xlSheet.UsedRange.Address

'比较所有选中的文字
For Each Ent In sel
    If LCase(Ent.ObjectName) = "acdbtext" Then
        Set textObj = Ent
       
'比较到相同的文字则保存下来
        j = 0
        For i = 1 To UsedRange.rows.Count
            If UsedRange.Offset(i, 1).Range("A1").Value = textObj.textString Then
                j = j + 1
                textString = textObj.textString = UsedRange.Offset(i, 2).Range("A1").Value
            End If
           
                i = i + 1
        Next
           
        If j <> 0 Then
            Height = textObj.Height
            start1 = textObj.InsertionPoint
            start1(0) = start1(0) + 10
            Set textObj = ThisDrawing.ModelSpace.AddText(textString, start1, Height)
            If j = 1 Then
                textObj.color = acBlue   'excel中文字只出现过一次，则文字为蓝色
            Else
                textObj.color = acRed   'excel中有复的文字，则文字改为红色
            End If
            newtextObj.Update
        End If
       
    End If
   
Next

Set xlRange = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
sel.Delete

End Sub

 

 

雪山飞狐_lzh

你的代码？

tsml

代码加上去了，谢谢！

mccad

简单一点是，先把Excel表中的数据读出，变成一个二维数组。在ACAD中选择文本后，直接与二维数组比较。