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

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