读取数据

mikefeng · 发表于 2005-2-1 17:31:00

如何用vba 读取excel中数据

wmz · 发表于 2005-2-3 11:50:00

Sub dsj()
   Dim Dlg As New CommonDialog
   Set hExcel = CreateObject("Excel.Application")
   hExcel.Visible = False
   Dim dyg As String,dmh(100) as String, i as integer,n As integer
   If sheet = "" Then
   Dlg.Filter = "Excel工作簿文件*.XLS|*.XLS|所有文件*.*|*.*"
   Dlg.ShowOpen
   sheet = Dlg.filename
   End If
   hExcel.Workbooks.Open (sheet), False
   n=100
   for i=1 to n
   dyg = "A" & Cstr(i)
   dmh = hExcel.Range(dyg).Text
   next i
   hExcel.Quit
End Sub

mikefeng · 发表于 2005-2-3 11:51:00

非常感谢

cqy · 发表于 2005-2-3 16:12:00

网上有CAD与EXCEL通信源码

mikefeng · 发表于 2005-2-4 10:36:00

该程序在运行中好象有点问题

cqy · 发表于 2005-2-4 13:56:00

For bEach blkElem In ThisDrawing.ModelSpace
改为：
For Each blkElem In ThisDrawing.ModelSpace
程序可用。

mikefeng · 发表于 2005-2-4 14:20:00

各位高人在指点迷津时能否更详细一点请不要悯惜笔墨

cqy · 发表于 2005-2-4 14:47:00

利用VBA 建立AutoCad2000与Excel通信
Sub    BlkAttr_Extract()
   Dim    Excel    As    Excel.Application
   Dim    ExcelSheet    As    Object
   Dim    ExcelWorkbook    As    Object
   '创建Excel应用程序实例
   On    Error    Resume    Next
   Set    Excel = GetObject(, "Excel.Application")
   If    Err  0    Then
   Set    Excel = CreateObject("Excel.Application")
   End    If
   '创建一个新工作簿
   Set    ExcelWorkbook = Excel.Workbooks.Add
   '确保Sheet1工作表为当前工作表
   Set    ExcelSheet = Excel.ActiveSheet
   '将新创建的工作簿保存为Excel文件
   ExcelWorkbook.SaveAs "属性表.xls"
   '令Excel应用程序可见
   Dim    RowNum    As    Integer
   Dim    Header    As    Boolean
   Dim    blkElem    As    AcadEntity
   Dim    Array1    As    Variant
   Dim    Count    As    Integer
   RowNum = 1
   Header = False
   '遍历模型空间，查找明细表的每个块引用表行
   For bEach    blkElem    In    ThisDrawing.ModelSpace
   With    blkElem
   '当一个块引用表行被找到后，检查它是否有属性
   If    StrComp(.EntityName, "AcDbBlockReference", 1) = 0    Then
   '如果有属性
   If . HasAttributes    Then
   '提取块引用中的属性
   Array1 = .GetAttributes
   '这一轮循环用来查找标题，如果有填在第1行
   For    Count = LBound(Array1)    To    UBound(Array1)
   '如果还没有标题
   If    Header = False    Then
   '作为标题的明细行其块属性常设为Constant类型
   If    Array1(Count).Constant    Then
   ExcelSheet.Cells(RowNum, Count + 1).Value _
   = Array1(Count).TextString
   End    If
   End    If
   Next    Count
   '从第2行开始，填写其它的明细表行内容
   RowNum = RowNum + 1
   For    Count = LBound(Array1)    To    UBound(Array1)
   ExcelSheet.Cells(RowNum, Count + 1).Value _
   = Array1(Count).TextString
   Next    Count
   Header = True
   End    If
   End    If
   End    With
   Next    blkElem
   '对填入当前表单的内容，按第1列进行排序,
   '范围是从A1单元格开始的整个工作表
   Excel.Worksheets("Sheet1").Range("A1").Sort _
   key1:=Excel.Worksheets("Sheet1").Columns("A"), _
   Header:=xlGuess
   '显示Excel工作表中的结果
   Excel.Visible = True
   '该语句用来等待查看显示结果
   MsgBox "按‘确定’键将关闭Excel的运行！"
   '保存传过来的数据
   ExcelWorkbook.Save
   '关闭Excel应用程序
   Excel.Application.Quit
   '删除Excel应用程序实例
   Set Excel = Nothing
End Sub