数据逐条按指定样式排版与判单数据插入行并统计数据

SCWYZJ · 发表于 2024-6-6 22:20

求助；1,数据逐条按指定样式排版在新表向下排列方便打印。2.依据月份不同判断并插入空行并对指定列数据进行小计与总计计算(详见附件），烦请老师帮忙看看如何写代码。谢谢

chxw68 · 发表于 2024-6-7 08:03

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("送货单")
r = .Cells(.Rows.Count, 2).End(xlUp).Row
arr = .Range("a5:k" & r)
End With
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 3))(i) = Empty
Next
With Worksheets("送货单列表")
.Cells.Clear
r = 3
For Each aa In d.keys
ReDim crr(1 To d(aa).Count, 1 To 4)
m = d(aa).keys()(0)
brr = Application.Transpose(Application.Transpose(Array(Array("日期:", arr(m, 2), "客户:", arr(m, 8)), Array("单号:", arr(m, 3), "联系:", arr(m, 9)), Array("备注:", arr(m, 11), "地址:", arr(m, 10)))))
m = 0
For Each bb In d(aa).keys
m = m + 1
crr(m, 1) = arr(bb, 4)
crr(m, 2) = arr(bb, 5)
crr(m, 3) = arr(bb, 6)
crr(m, 4) = arr(bb, 7)
Next
With .Cells(r, 2)
.Value = "送货单"
.Resize(1, 4).Merge
End With
.Cells(r + 1, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
.Cells(r + 5, 2).Resize(1, 4) = Array("产品", "单价", "数量", "金额")
.Cells(r + 6, 2).Resize(UBound(crr), UBound(crr, 2)) = crr
.Cells(r + 6 + UBound(crr), 4) = "合计:"
With .Cells(r + 6 + UBound(crr), 5)
.Value = Application.Sum(Application.Index(crr, 0, 4))
.NumberFormatLocal = "￥#,##0.00_);[红色](￥#,##0.00)"
.Font.ColorIndex = 3
End With
With .Cells(r + 1, 2).Resize(3, 4)
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
End With
With .Cells(r + 6, 2).Resize(UBound(crr), 4)
With .Borders(xlEdgeBottom)
.LineStyle = xlDot
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlDot
End With
End With
With .Cells(r + 6, 3).Resize(UBound(crr), 1)
.NumberFormatLocal = "￥#,##0.00_);[红色](￥#,##0.00)"
End With
With .Cells(r + 6, 5).Resize(UBound(crr), 1)
.NumberFormatLocal = "￥#,##0.00_);[红色](￥#,##0.00)"
End With
r = r + 6 + UBound(crr) + 2
Next
With .UsedRange
With .Font
.Name = "等线"
.Size = 18
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2024-6-7 08:04

只作了第一问。

SCWYZJ · 发表于 2024-6-7 09:17

chxw68 发表于 2024-6-7 08:04
只作了第一问。

谢谢老师，可以。不愧是大神

SCWYZJ · 发表于 2024-6-7 11:11

chxw68 发表于 2024-6-7 08:03

老师好：我有疑难题请教，AI提问都没有结果，想来此请教：A1单元格中数据：买菜12.50元，搬货收入200块，卖1块香皂7.5块，打牌输-200元。我想用正则表达式提取正数并求和。12.50+200+7.5=220 请问老师如何写正则表达式。谢谢

chxw68 · 发表于 2024-6-7 11:37

我对正则表达式也不是十分精通，参考吧。

Sub test()
Dim r%, i%
Dim reg As New RegExp
With reg
.Global = True
.Pattern = "(-?(?:\d+\.\d+|\d+))[元块]"
ss = "买菜12.50元，搬货收入200块，卖1块香皂7.5块，打牌输-200元"
Set mh = .Execute(ss)
s = 0
For j = 0 To mh.Count - 1
x = Val(mh(j).SubMatches(0))
If x > 0 Then
s = s + x
End If
Next
MsgBox s
End With
End Sub

复制代码

3190496160 · 发表于 2024-6-7 14:29

Sub 删除小计总计()
Application.ScreenUpdating = False
Dim rn As Range
With ActiveSheet
r = .Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To r
      If .Cells(i, 3) = "小计" Or .Cells(i, 3) = "总计" Then
         If rn Is Nothing Then
            Set rn = .Rows(i)
         Else
            Set rn = Union(rn, .Rows(i))
         End If
      End If
Next i
If Not rn Is Nothing Then rn.Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
Sub 插入小计总计()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim rn As Range
With ActiveSheet
r = .Cells(Rows.Count, 3).End(xlUp).Row
ar = .Range("a1:e" & r)
For i = 3 To UBound(ar)
      If ar(i, 2) <> "" Then
         If Not d.exists(ar(i, 2)) Then Set d(ar(i, 2)) = CreateObject("scripting.dictionary")
         d(ar(i, 2))(i) = ""
      End If
Next i
.Range("a3:e" & r) = Empty
ReDim br(1 To UBound(ar) * 2, 1 To UBound(ar, 2))
For Each k In d.keys
      hj1 = 0: hj2 = 0
      For Each kk In d(k).keys
         n = n + 1
         For j = 1 To UBound(ar, 2)
            br(n, j) = ar(kk, j)
         Next j
         hj1 = hj1 + ar(kk, 4)
         hj2 = hj2 + ar(kk, 5)
         zj1 = zj1 + ar(kk, 4)
         zj2 = zj2 + ar(kk, 5)
      Next kk
      n = n + 1
      br(n, 3) = "小计"
      br(n, 4) = hj1
      br(n, 5) = hj2
Next k
n = n + 1
br(n, 3) = "总计"
br(n, 4) = zj1
br(n, 5) = zj2
.[a3].Resize(n, UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-6-7 14:30

Private Sub CommandButton1_Click()
With CommandButton1
If .Caption = "插入小计" Then
      Call 插入小计总计
      .Caption = "删除小计"
ElseIf .Caption = "删除小计" Then
      Call 删除小计总计
      .Caption = "插入小计"
End If
End With
End Sub

3190496160 · 发表于 2024-6-7 14:31

一个按钮两个功能

送货单（带制作）.rar (56.64 KB, 下载次数: 3)

SCWYZJ · 发表于 2024-6-7 16:32

3190496160 发表于 2024-6-7 14:30
Private Sub CommandButton1_Click()
With CommandButton1
If .Caption = "插入小计" Then

谢谢老师，完美，牛

		自动登录	找回密码
密码			免费注册

数据逐条按指定样式排版与判单数据插入行并统计数据

评分

评分