VBA代码填入数据并计算数据总和

我现在CAD中加入了一串代码，可以正常运行，这串代码可以自动启动excel，同时也可以自动关闭excel的，现在我要求在CAD的代码中增加代码，这个代码的要求是：自动计算excel某一列的数据总和，计算结果填入某一列中

10 个解决方案

#1

既然能启动Excel，就能用Excel的Application对象吧，Application.WorksheetFunction.Sum()可求和。

#2

该回复于2011-09-13 13:51:19被版主删除

#3

假设EXCEL有3列：

订货数量价格总订货数量
200 30
50 25
100 7
70 8

把订货数量相加，填到总订货数量

#4

Private Sub Form_Load()
某列值累加并填写到另一列bt_Click
End Sub

Public Function GetExcelRs(ByVal sFile As String, Optional ExcelSheetName As String = "sheet1", Optional ErrInfo As String) As ADODB.Recordset
On Error GoTo Err
Dim RS As ADODB.Recordset
Set RS = New ADODB.Recordset
Dim ConnStr As String
ConnStr = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sFile & ";ReadOnly=False"

RS.Open "SELECT * FROM [" & ExcelSheetName & "$]", ConnStr, 1, 3

Set GetExcelRs = RS
Set RS = Nothing

Exit Function
Err:
ErrInfo = Err.Description
MsgBox ErrInfo
End Function
Public Function GetExcelRsBySql(ByVal sFile As String, Optional Sql As String, Optional ErrInfo As String) As ADODB.Recordset
On Error GoTo Err
Dim RS As ADODB.Recordset
Set RS = New ADODB.Recordset
Dim ConnStr As String
ConnStr = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sFile & ";ReadOnly=False"

RS.Open Sql, ConnStr, 1, 3

Set GetExcelRsBySql = RS
Set RS = Nothing

Exit Function
Err:
ErrInfo = Err.Description
MsgBox ErrInfo
End Function



Private Sub 读写bt_Click()
Dim RS As ADODB.Recordset
Set RS = GetExcelRs(App.Path & "\book1.xls")
MsgBox RS.RecordCount
MsgBox RS(0)
RS(0) = Timer '更改内容
RS.CancelUpdate '取消更新
RS.Update '保存更新
RS.Close
End Sub

Private Sub 某列值累加并填写到另一列bt_Click()
Dim RS As ADODB.Recordset
Set RS = GetExcelRsBySql(App.Path & "\book1.xls", "select sum(订货数量) as 订货数量相加 from (SELECT * FROM [sheet1$])")
Dim 结果 As Long
结果 = RS(0)
MsgBox "相加的值是：" & 结果
RS.Close


Set RS = GetExcelRs(App.Path & "\book1.xls")
RS("总订货数量") = 结果
RS.Update

MsgBox "保存后字段[总订货数量] 的值是：" & RS("总订货数量")
RS.Close
End Sub

#5

Public Sub dtexcel()
Dim ACAD As Object
Dim STRNAME, BCNAME As String
Dim Header As Boolean
Dim Excel As Excel.Application '声明Excel应用程序对象变量
Dim ExcelSheet As Object '定义Excel工作表
'创建Excel应用程序实例
On Error Resume Next '激活Excel应用程序
Set Excel = GetObject(, "Excel.Application") 'Excel应用程序已经运行，则获得它的对象实例
If Err <> 0 Then '如果Excel应用程序未运行
   Set Excel = CreateObject("Excel.Application") '创建Excel应用程序实例
End If
Set ExcelWorkbook = Excel.Workbooks.Add '创建一个新工作簿
Set ExcelSheet = Excel.ActiveSheet '确保Sheet1工作表为当前工作表
Dim objExl As Excel.Application
Range("A1:A900").Select
Selection.NumberFormatLocal = "@" '设置格式为文本
Selection.HorizontalAlignment = xlleft '选定单元格左对齐
STRNAME = ThisDrawing.Name '当前打开的文件名
BCNAME = "T" & Mid(STRNAME, 1, InStrRev(STRNAME, ".")) + "XLS" '截取点前的文件名组合为电子表名
MsgBox "提取的数据将保存在：D:\" & BCNAME & "中，按确定继续...", , "浩智电子杜昌立提示您"
RowNum = 3 '明细起始行
'扫描模型空间，查找明细表引用块行
For Each blkElem In ThisDrawing.ModelSpace
  With blkElem
  '当一个块行被找到后，检查它是否有属性
  If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then '如果有属性
    RowNum = RowNum + 1
    If .HasAttributes Then
    Array1 = .GetAttributes
    '提取普通模式块的属性引用中的属性
     For Count = LBound(Array1) To UBound(Array1)
         If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
            tqtj = Array1(Count).TagString
               '符合下一条件的块才提取值，控制明细规范以外的块不提取
              If tqtj = "位置" Or tqtj = "护套" Or tqtj = "端子" Or tqtj = "线号/代号" Or tqtj = "编码" Or tqtj = "规格" Or tqtj = "品牌" Or tqtj = "起点" Or tqtj = "途径" Or tqtj = "终点" Or tqtj = "剥皮一" Or tqtj = "剥皮二" Or tqtj = "锁件" Or tqtj = "防水栓" Or tqtj = "波纹管" Or tqtj = "其它附件" Or tqtj = "加余量 " Or tqtj = "备注" Then
                ExcelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
              End If
         End If
        ''''''
     Next Count
        Header = Ture
      End If
   End If
  End With
Next blkElem
'将新创建的工作簿保存为Excel文件
'自动填写表头行标题字段
Worksheets("sheet1").Range("A1").Value = "图纸文件：" + BCNAME
Worksheets("sheet1").Range("A2").Value = "位置"
Worksheets("sheet1").Range("B2").Value = "护套"
Worksheets("sheet1").Range("C2").Value = "端子"
Worksheets("sheet1").Range("D2").Value = "线号/代号"
Worksheets("sheet1").Range("E2").Value = "编码"
Worksheets("sheet1").Range("F2").Value = "规格"
Worksheets("sheet1").Range("G2").Value = "品牌"
Worksheets("sheet1").Range("H2").Value = "起点"
Worksheets("sheet1").Range("I2").Value = "途径"
Worksheets("sheet1").Range("J2").Value = "终点"
Worksheets("sheet1").Range("K2").Value = "剥皮一"
Worksheets("sheet1").Range("L2").Value = "剥皮二"
Worksheets("sheet1").Range("M2").Value = "锁件"
Worksheets("sheet1").Range("N2").Value = "防水栓"
Worksheets("sheet1").Range("O2").Value = "波纹管"
Worksheets("sheet1").Range("P2").Value = "其它附件"
Worksheets("sheet1").Range("Q2").Value = "加余量"
Worksheets("sheet1").Range("R2").Value = "备注"

'''''''''''
'对填入当前表的内容，对明细栏提取的值进行排序
'从A列3行至R列900行排序保证1至2行标题栏不受影响
Excel.Worksheets("Sheet1").Range("A3:M900").Sort _
Key1:=Excel.Worksheets("Sheet1").Columns("A")
    ChDir "D:\"
    ExcelWorkbook.SaveAs FileName:="D:\" & BCNAME, FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
'调整列宽
Worksheets("sheet1").Columns("A:A").EntireColumn.AutoFit
Worksheets("sheet1").Columns("B:B").EntireColumn.AutoFit
Worksheets("sheet1").Columns("C:C").EntireColumn.AutoFit
Worksheets("sheet1").Columns("D:D").EntireColumn.AutoFit
Worksheets("sheet1").Columns("E:E").EntireColumn.AutoFit
Worksheets("sheet1").Columns("F:F").EntireColumn.AutoFit
Worksheets("sheet1").Columns("G:G").EntireColumn.AutoFit
Worksheets("sheet1").Columns("H:H").EntireColumn.AutoFit
Worksheets("sheet1").Columns("I:I").EntireColumn.AutoFit
Worksheets("sheet1").Columns("J:J").EntireColumn.AutoFit
Worksheets("sheet1").Columns("K:K").EntireColumn.AutoFit
Worksheets("sheet1").Columns("L:L").EntireColumn.AutoFit
Worksheets("sheet1").Columns("M:M").EntireColumn.AutoFit
Worksheets("sheet1").Columns("N:N").EntireColumn.AutoFit
Worksheets("sheet1").Columns("O:O").EntireColumn.AutoFit
Worksheets("sheet1").Columns("P:P").EntireColumn.AutoFit
Worksheets("sheet1").Columns("Q:Q").EntireColumn.AutoFit
Worksheets("sheet1").Columns("R:R").EntireColumn.AutoFit
'ExcelWorkbook.SaveAs "d:\" + BCNAME '存盘
'显示Excel工作表中的结果
Excel.Visible = True
MsgBox "按确定键将关闭Excel的运行！", , "浩智电子杜昌立提示您"
'保存传过来的数据
ExcelWorkbook.Save
'关闭Excel应用程序
Excel.Application.Quit
'删除Excel应用程序实例
Set Excel = Nothing
End Sub
[size=10px] 以上是再CAD里面的代码，希望xiaoyao961帮我调试，问题处理后追加100分！！

#6

我现在需要解决是途径的数据相加，我在CAD中会有L1、L2、L3、L4、........等等的长度，希望代码能自动相加后填入excel的某一列

#7

突然想到了一个问题，就是L1、L2、L3等等所代替的长度设置问题，怎么才能将各个长度传递给代码？也就是说代码怎么知道L1等于多长？请各位帮我想想，我想的是在CAD代码点击执行前提示录入L1等于多长的数据，由代码保存，然后由代码自动将L1、L2..相加，各位大哥看看可行吗？

#8

我没有用过 CAD，也没有 CAD 文件，对程序不好说什么，但对程序中的部分代码的写法有建议
1. If tqtj = "位置" Or tqtj = "护套" Or tqtj = "端子" Or .........
可以写成：
s = "|位置|护套|端子|线号/代号|编码|规格|品牌|起点|途径|终点|剥皮一|剥皮二|锁件|防水栓|波纹管|其它附件|加余量|备注|"
If InStr(1, s, "|" & tqtj & "|") Then
s 变量在以下还要用到

2.Worksheets("sheet1").Range("A2").Value = "位置"
Worksheets("sheet1").Range("B2").Value = "护套"
.........

改成：
Worksheets("sheet1").Range("A2:S2") = Split(Mid(s, 2), "|")

s 就是上面 s 的定义，一句话就可完成。

3.Worksheets("sheet1").Columns("A:A").EntireColumn.AutoFit
.............

改成：Worksheets("sheet1").Columns("A:R").EntireColumn.AutoFit
一句话就可完成。

#9

我不知道L1、L2、L3.....是什么，如果能取到 Excel 中，就可以计算了，能将它取到 Excel 中吗？

#10

CAD可以将L1、L2、L3等传到EXCEL中的，只是L1等于多少的问题没有解决，也就是说L1的长度问题怎么转换给excel没有想到办法

#1