[已解决]求助高手！请大神帮忙！

mqbmzm

求助如何在EXCEL中用宏代码解决下面的问题：
        已有数据源如表一：

表一
项目编号	姓名	产品A	产品B	产品C
A	a	2	6
A	a	1	5
A	b	5	9
A	c	7	3
A	c	3	5
B	b	5	4
B	c	7	8
B	d	5	4
C	a	6	7
C	a	2	3
C	b	8	5
C	c	8	5
D	a	5	8
D	d	7	2
D	d	2	5
D	d	2	5
D	e	3	9
E	a	9	0
E	b	3	4
E	d	2	0

在EXCEL中用宏代码生成下表二：

表二
项目编号	姓名	产品A	产品B	产品C
A	a	3	11
A	b	5	9
A	c	10	8
A小计		18	28
B	b	5	4
B	c	7	8
B	d	5	4
B小计		17	16
C	a	8	10
C	b	8	5
C	c	8	5
C小计		24	20
D	a	5	8
D	d	11	12
D	e	3	9
D小计		19	29
E	a	9	0
E	b	3	4
E	d	2	0
E小计		14	4
合计		92	97	0

谢谢大神帮助！

最佳答案

月排行榜 / 总排行榜

高

2021-4-2 11:58

mqbmzm 发表于 2021-4-2 10:15
谢谢您！
但是如果产品列数再增加时，应如何解决？

如果列增减，用这个

跳转到最佳答案楼层

mqbmzm

高 发表于 2021-4-2 11:58
如果列增减，用这个

谢谢您！为您点赞！

mqbmzm

王宪 发表于 2021-4-2 10:13
wps没用过，excel2013测试通过
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = ...

我试了下，用OFFICE EXCEL是可以的！谢谢您！大神！

高

mqbmzm 发表于 2021-4-2 10:15
谢谢您！
但是如果产品列数再增加时，应如何解决？

如果列增减，用这个

mqbmzm

高 发表于 2021-4-1 13:38
可能代码啰嗦了。因你没有附件，所以代码做了些特殊处理。例如你表一中的“项目编号”可以放在任意位置。同 ...

谢谢您！
但是如果产品列数再增加时，应如何解决？

王宪

mqbmzm 发表于 2021-4-2 10:02
首先，谢谢您！
在执行“汇总”时，走不下去。   到这一步 conn.Open cnstr，提示错误“3706”.我用的是 ...

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

mqbmzm

王宪 发表于 2021-3-31 18:11
自动分类汇总

首先，谢谢您！
在执行“汇总”时，走不下去。   到这一步 conn.Open cnstr，提示错误“3706”.我用的是WPS 11.1

高

可能代码啰嗦了。因你没有附件，所以代码做了些特殊处理。例如你表一中的“项目编号”可以放在任意位置。同时也有一个要求，就是工作表名是表一、表二。

mqbmzm

hcm19522 发表于 2021-3-31 17:21
G2:G23{=IFERROR(IF((INDEX(A:A,SMALL(IF(MATCH(A$2:A$21&B$2:B$21,A$2:A$21&B$2:B$21,)=ROW($1:$20),ROW($ ...

谢谢您！
能否给一种宏代码的方案？

王宪

自动分类汇总