请求高手帮忙写段代码批量从表格中提取某几个字段列到新表中并求和 - VB6论坛

jackh

等　级：新手上路
帖　子：26
专家分：0
注　册：2017-11-9
结帖率：66.67%

楼主

已结贴√ 问题点数：20 回复次数：18

请求高手帮忙写段代码批量从表格中提取某几个字段列到新表中并求和

新建文件夹.rar (107.78 KB)

搜索更多相关主题的帖子: 表格　提取　字段　表中　求和　

2019-01-02 21:00

jackh

等　级：新手上路
帖　子：26
专家分：0
注　册：2017-11-9

第 3 楼

得分:0

从地块信息中提取信息并汇总到图2新表中

2019-01-02 21:05

icecool

等　级：贵宾
威　望：20
帖　子：1214
专家分：1366
注　册：2005-3-14

第 5 楼

得分:2

程序代码：

Private Sub CommandButton1_Click()


 Dim dbAddr
    dbAddr = ThisWorkbook.Path & "\" & "官塘驿镇白羊村一组村民小组湖北地信Excel文件.xls"
    Dim Conn As ADODB.Connection  '连接
    Set Conn = New ADODB.Connection

    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    connstrxls = "DBQ=" & dbAddr & ";DefaultDir=;DRIVER={Microsoft Excel Driver (*.xls)};"
    Conn.Open connstrxls
Sql = "select * from [地块信息$] order by 承包方编码"
rs.Open Sql, Conn

i = 2
Do While Not rs.EOF
    Range("A" & i) = rs("承包方编码")
    Range("b" & i) = rs("承包方名称")
    Range("C" & i) = rs("宗地坐落")
    Range("D" & i) = rs("宗地编码")
    Range("E" & i) = rs("宗地名称")
    Range("F" & i) = rs("土地类型")
    Range("G" & i) = rs("实测面积")
    i = i + 1
   rs.MoveNext
Loop

Application.DisplayAlerts = False
irows = ActiveSheet.UsedRange.Rows.Count

For m = irows To 2 Step -1
    If Cells(m, 1) = Cells(m - 1, 1) Then
       Range(Cells(m - 1, 1), Cells(m, 1)).Merge
       Range(Cells(m - 1, 2), Cells(m, 2)).Merge
       Range(Cells(m - 1, 3), Cells(m, 3)).Merge
       Range(Cells(m - 1, 8), Cells(m, 8)).Merge
       Range(Cells(m - 1, 9), Cells(m, 9)).Merge
       Range(Cells(m - 1, 10), Cells(m, 10)).Merge
       Range(Cells(m - 1, 11), Cells(m, 11)).Merge
    End If
Next

End Sub