从地块信息中提取信息并汇总到图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

求和部份没空弄，自已看一下加上代码就可以了

运行时有错误

要引用ado组件

我上传的要个文件要放一起运行

我把表版本转成97版了，注意文件名及后缀
官塘驿镇白羊村一组村民小组湖北地信Excel文件.xls

附件代码供参考（没做优化），一般来说参照代码，肯定能做出你要的结果

1、根据原始表提取出目的表
2、目的表只对第一个人员做了格式处理
3、其实控制输出格式可以用循环及数组的，自己琢磨着做。



做了格式处理，你看看。

[此贴子已经被作者于2019-1-3 15:52编辑过]