根据表1农户名字生成表2显示样式的表格

今日123

沈默00 发表于 2025-2-26 14:17
确实 ，，，其实就是个苦力活，，，，
现在DEEPSEEK很厉害的，，，AI函数也很厉害，，，慢慢的这些做苦 ...

没错，DEEP SEEK 写代码能力超厉害，还能指出论坛里各种代码的有点还有哪些可以改进的地方，只要讲清楚需求，代码一分钟就写好了

今日123

啥都好了 deep seek 就是服务器一直繁忙

今日123

用全数组操作编写试试看 Sub 拆分数据表()
Dim arr(), brr(), crr(), borderRanges()
Dim s, cnt, j, dict As Object, i&, m&, k&, 标题
Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary")
With Sheets("表1").Range("A1").CurrentRegion
    arr = .Offset(1).Resize(.Rows.Count - 1).Value
    For i = 1 To UBound(arr)
        s = arr(i, 7)
        If Not dict.Exists(s) Then dict(s) = 0
        dict(s) = dict(s) + arr(i, 6)
    Next i
End With
ReDim brr(1 To UBound(arr) * 4, 1 To 6), borderRanges(1 To dict.Count, 1 To 2)
标题 = Split("品名|规格|单位|数量|单价|金额", "|"): crr = dict.keys
For m = 0 To UBound(crr)
    cnt = k + 1
    k = k + 1: brr(k, 1) = m + 1 & "、代销清单：" & crr(m)
    k = k + 1
    For i = 0 To UBound(标题)
        brr(k, i + 1) = 标题(i)
    Next i
    For i = 1 To UBound(arr) ' 批量填充数据行
        If arr(i, 7) = crr(m) Then
            k = k + 1
            For j = 1 To 6
                brr(k, j) = arr(i, j)
            Next j
        End If
    Next
    k = k + 1
    brr(k, 5) = "合计："
    brr(k, 6) = dict(crr(m))        ' 写入合计行
    borderRanges(m + 1, 1) = cnt    ' 记录结束行
    borderRanges(m + 1, 2) = k
    k = k + 1                       ' 空行
Next m
With Sheets("表2")
    .Cells.Clear
    .Range("A1").Resize(k, 6).Value = brr
    .Columns(6).NumberFormat = "0.00"
    .Columns.AutoFit
   
    ' 批量设置边框
    For m = 1 To UBound(borderRanges)
        With .Range("A" & borderRanges(m, 1) & ":F" & borderRanges(m, 2))
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThin
            .Rows(2).Borders(xlEdgeBottom).Weight = xlMedium
            .Rows(.Rows.Count).Borders(xlEdgeTop).Weight = xlMedium
        End With
    Next
End With
Application.ScreenUpdating = True
End Sub

今日123

表格的格式代码 改了一下。 Sub 拆分数据表()
Dim arr(), brr(), crr(), borderRanges()
Dim s, cnt, j, dict As Object, i&, m&, k&, 标题
Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary")
With Sheets("数据").Range("A1").CurrentRegion
    arr = .Offset(1).Resize(.Rows.Count - 1).Value
    For i = 1 To UBound(arr)
        s = arr(i, 7)
        If Not dict.Exists(s) Then dict(s) = 0
        dict(s) = dict(s) + arr(i, 6)
    Next i
End With
ReDim brr(1 To UBound(arr) * 4, 1 To 6), borderRanges(1 To dict.Count, 1 To 2)
标题 = Split("品名|规格|单位|数量|单价|金额", "|"): crr = dict.keys
For m = 0 To UBound(crr)
    cnt = k + 1
    k = k + 1: brr(k, 1) = m + 1 & "、代销清单：" & crr(m)
    k = k + 1
    For i = 0 To UBound(标题)
        brr(k, i + 1) = 标题(i)
    Next i
    For i = 1 To UBound(arr) ' 批量填充数据行
        If arr(i, 7) = crr(m) Then
            k = k + 1
            For j = 1 To 6
                brr(k, j) = arr(i, j)
            Next j
        End If
    Next
    k = k + 1
    brr(k, 5) = "合计："
    brr(k, 6) = dict(crr(m))        ' 写入合计行
    borderRanges(m + 1, 1) = cnt    ' 记录结束行
    borderRanges(m + 1, 2) = k
    k = k + 1                       ' 空行
Next m
With Sheets("汇总")
    .Cells.Clear
    .Range("A1").Resize(k, 6).Value = brr
    .Columns(6).NumberFormat = "0.00"
    .Columns.AutoFit
   
    ' 批量设置边框
    For m = 1 To UBound(borderRanges)
        With .Range("A" & borderRanges(m, 1) & ":F" & borderRanges(m, 2))
            With .Rows(1)
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThin
            .Rows(2).Borders(xlEdgeBottom).Weight = xlMedium
            .Rows(.Rows.Count).Borders(xlEdgeTop).Weight = xlMedium
        End With
    Next
End With
Application.ScreenUpdating = True
End Sub