wps没用过,excel2013测试通过
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim conn As Object
Dim rs As Object
Dim irow, iclo, i, ia
Dim sql, sqla, cnstr
Dim arr()
Sheet2.Cells.Delete Shift:=xlUp
cnstr = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & ThisWorkbook.FullName
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open cnstr
iclo = Range("A2").End(xlToRight).Column
irow = Range("A10000").End(3).Row
For i = 3 To iclo
sqla = sqla & "sum(" & Cells(2, i) & "),"
Next
arr = Range(Cells(2, 1), Cells(2, iclo))
sqla = Left(sqla, Len(sqla) - 1)
sqla = Cells(2, 1) & "," & Cells(2, 2) & "," & sqla
sql = "select " & sqla & " from [" & Sheet1.Name & "$"
sql = sql & Application.Substitute(Range(Cells(2, 1), Cells(irow, iclo)).Address, "$", "") & "]"
sql = sql & " group by " & Cells(2, 1) & "," & Cells(2, 2)
rs.Open sql, conn, 3, 3
With Sheet2
.Range("A2").Resize(1, iclo) = arr
.Rows("3:1000").Delete
.Range("A3").CopyFromRecordset rs
irow = .Range("A10000").End(3).Row
If irow = 2 Then Exit Sub
i = 4
ia = 3
Do While i <= irow
If .Cells(i, 1) <> .Cells(i - 1, 1) And .Cells(i - 1, 1) <> "" Then
.Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1) = .Cells(i - 1, 1) & "小计"
.Range(.Cells(i, 3), .Cells(i, iclo)).FormulaR1C1 = "=sum(R[-" & i - ia & "]C:R[-1]C)"
irow = irow + 1
ia = i + 1
i = i + 2
Else
i = i + 1
End If
Loop
If i = irow + 1 Then
.Cells(i, 1) = .Cells(i - 1, 1) & "小计"
.Range(.Cells(i, 3), .Cells(i, iclo)).FormulaR1C1 = "=sum(R[-" & i - ia & "]C:R[-1]C)"
End If
ia = .Range("A10000").End(3).Row + 1
If ia = 3 Then Exit Sub
sql = "=sum("
For i = 3 To .Range("A10000").End(3).Row
If InStr(.Cells(i, 1), "小计") > 1 Then sql = sql & "R[-" & ia - i & "]C,"
Next
sql = Left(sql, Len(sql) - 1)
.Range(.Cells(ia, 3), .Cells(ia, iclo)).FormulaR1C1 = sql & ")"
.Range("A" & ia) = "合计"
.Activate
End With
Application.ScreenUpdating = True
End Sub
|