真不会了 窗体汇总问题 请老师出手解决下

1013182120

用kimi写了个汇总，能汇总多个工作簿，但是汇总不了工作簿下的全部工作表，具体需求在压缩包里，请各位老师出手解决下，再次感谢各位老师。

3190496160

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim ar(), br(), arr()
With Me.ListBox1
    ReDim ar(1 To .ListCount)
    ReDim br(1 To .ListCount)
    For i = 0 To .ListCount - 1
        If .Selected(i) = True Then
            If InStr(.List(i, 0), "xls") > 0 Then
                m = m + 1
                br(m) = i
            End If
        End If
    Next i
    m = m + 1
    br(m) = .ListCount - 1
    If m = 1 Then MsgBox "请选择要汇总的工作簿和相应的工作表": Exit Sub
    ReDim arr(1 To 100000, 1 To 18)
    For i = 1 To m - 1
        ks = br(i) + 1
        js = br(i + 1) - 1
        wj = .List(br(i), 0)
        f = Dir(ThisWorkbook.Path & "\合并\" & wj)
        If f <> "" Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\合并\" & wj)
            For s = ks To js
                If .Selected(s) = True Then
                    gzb = .List(s, 0)
                    Set sh = wb.Worksheets(gzb)
                    With sh
                        mr = .[a1].CurrentRegion
                    End With
                    For ii = 3 To UBound(mr)
                        If mr(ii, 2) <> "" Then
                            n = n + 1
                            arr(n, 1) = n
                            For j = 1 To UBound(mr, 2)
                                arr(n, j + 1) = mr(ii, j)
                            Next j
                            arr(n, 3) = "" & arr(n, 3)
                            arr(n, 18) = ThisWorkbook.Path & "\合并\" & wj
                        End If
                    Next ii
                End If
            Next s
            wb.Close False
        End If
    Next i
End With
With Sheets(1)
    .[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a4].Resize(n, UBound(arr, 2)) = arr
    .[a3].Resize(n + 1, UBound(arr, 2)).Borders.LineStyle = 1
    For j = 5 To 17
        If j <> 12 And j <> 13 Then
            .Cells(3, j) = Application.Sum(.Range(.Cells(4, j), .Cells(n + 3, j)))
        End If
    Next j
    .[d3] = "合计"
End With
Application.ScreenUpdating = True
MsgBox "合并完毕！"
End Sub

3190496160

Desktop.rar (430.32 KB, 下载次数: 16)

2024-9-8 11:16 上传

点击文件名下载附件

3190496160

合并的代码时重新写的，仅供参考
一点建议：不是所有的功能都得要用代码来完成的，比如，列标题，单元格格式等，还是用数组比频繁写入单元格速度要快很多倍

1013182120

老师 谢谢老师的出手 还是有点出入 我希望是根据品名（第3列）进行分组汇总（需要汇总的列是4 6 8 10 13 14 15 16 ）列，还有最后生成的不是超链接，2个日期（日期和入库日期）列可不要，其他不汇总的
列保留

1013182120

3190496160 发表于 2024-9-8 11:17
合并的代码时重新写的，仅供参考
一点建议：不是所有的功能都得要用代码来完成的，比如，列标题，单元格格 ...

老师运行时出现小问题了

3190496160

1013182120 发表于 2024-9-8 12:30
老师 谢谢老师的出手 还是有点出入 我希望是根据品名（第3列）进行分组汇总（需要汇总的列是4 6 8 10 13 14 ...

呵呵呵，你现在所说的，跟你代码所表示的千差万别，再谈错误与否似乎就没有任何价值了吧

1013182120

3190496160 发表于 2024-9-8 19:57
呵呵呵，你现在所说的，跟你代码所表示的千差万别，再谈错误与否似乎就没有任何价值了吧

谢谢老师指点

1013182120

3190496160 发表于 2024-9-8 19:57
呵呵呵，你现在所说的，跟你代码所表示的千差万别，再谈错误与否似乎就没有任何价值了吧

这个错误是加个空表进去就行了，最后一张不提取数据，谢谢

3190496160

1013182120 发表于 2024-9-8 20:18
这个错误是加个空表进去就行了，最后一张不提取数据，谢谢

可以加我v具体沟通