绿色蔬菜种植 发表于 2021-10-30 16:23:01

刘兴辉 发表于 2021-11-2 14:43:58

Sub 数据整理()
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("发票")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:n" & rs)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 8)) <> "" And Trim(ar(i, 14)) = "是" Then
d(Trim(ar(i, 8))) = d(Trim(ar(i, 8))) + 1
End If
Next i
ReDim brr(1 To d.Count, 1 To 7)
For Each k In d.keys
n = 0
je = 0: se = 0: js = 0
zf = "": y = 0: dc.RemoveAll
xh = "": zff = ""
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 8)) = k And Trim(ar(i, 14)) = "是" Then
    n = n + 1
    je = je + ar(i, 9)
    se = se + ar(i, 10)
    js = js + ar(i, 11)
    For j = 1 To UBound(ar, 2)
      br(n, j) = ar(i, j)
    Next j
End If
Next i
For i = 1 To n
For s = i + 1 To n
    If br(i, 3) > br(s, 3) Then
      For j = 1 To UBound(br, 2)
      kk = br(i, j)
      br(i, j) = br(s, j)
      br(s, j) = kk
      Next j
    End If
Next s
Next i
For i = 1 To n
For s = i + 1 To n
    If Val(br(i, 3)) + 1 = Val(br(s, 3)) Then
      y = y + 1
      If y = 1 Then
      zf = br(i, 3) & "," & br(s, 3)
      dc(br(i, 3)) = ""
      dc(br(s, 3)) = ""
      ElseIf y > 1 Then
      If Not dc.exists(br(i, 3)) And Not dc.exists(br(s, 3)) Then
      zf = zf & "," & br(i, 3) & "," & br(s, 3)
      dc(br(s, 3)) = ""
      dc(br(i, 3)) = ""
      ElseIf Not dc.exists(br(i, 3)) And dc.exists(br(s, 3)) Then
      zf = zf & "," & br(i, 3)
      dc(br(i, 3)) = ""
      ElseIf dc.exists(br(i, 3)) And Not dc.exists(br(s, 3)) Then
      zf = zf & "," & br(s, 3)
      dc(br(s, 3)) = ""
      End If
      End If
    End If
Next s
Next i
If zf <> "" Then
rr = Split(zf, ",")
For i = 0 To UBound(rr) - 1
    If Val(rr(i)) + 1 <> Val(rr(i + 1)) Then
      xh = i
      Exit For
    End If
Next i
End If
For i = 1 To n
If Not dc.exists(br(i, 3)) Then
    If zff = "" Then
      zff = br(i, 3)
    Else
      zff = zff & "," & br(i, 3)
    End If
End If
Next i
m = m + 1
If zf <> "" Then
If xh = "" Then
    brr(m, 4) = "发票代码" & br(1, 2) & "," & rr(0) & "至" & rr(UBound(rr)) & "," & zff
ElseIf xh <> "" Then
    brr(m, 4) = "发票代码" & br(1, 2) & "," & rr(0) & "至" & rr(xh) & "," & rr(xh + 1) & "至" & rr(UBound(rr)) & "," & zff
End If
ElseIf zf = "" Then
brr(m, 4) = "发票代码" & br(1, 2) & "," & zff
End If
brr(m, 1) = k
brr(m, 2) = br(1, 1)
brr(m, 3) = d(k)
brr(m, 5) = je
brr(m, 6) = se
brr(m, 7) = js
Next k
With Sheets("输出样式")
..CurrentRegion.Offset(1) = Empty
..Resize(m, UBound(brr, 2)) = brr
End With
MsgBox "ok!"
End Sub

云巢 发表于 2021-11-9 00:50:16

钮祜禄壮壮 发表于 2021-11-10 09:29:23

PQ（EXCEL2016及以上自带）解法
使用方法：发票那张表数据变化后，在结果表（输出样式表的第20-26行）数据上点击右键，选择刷新

阳光遇上玻璃窗 发表于 2021-11-16 20:38:21

代码有缺陷，发票表第5行是8438639，不是8438629，而你的结果是发票号码08438626至08438631

彼方尚有荣光在 发表于 2021-11-19 20:14:20

PQ确实厉害。。。怎么学啊，看着好复杂

赵松林 发表于 2021-11-22 02:03:13


我采用的是excel2010版本的数据透视表做的，做完后删除透视表。

哥的爱很实在 发表于 2021-11-22 11:40:52

按“发票代码”分组，将连续的“发票号码”整合，单独的“发票号码”则单独列示
发票号码08438634至08438637
这种，要计算机完全适应人，要自动化比较难

用户怀哥 发表于 2021-11-28 00:19:58

这个问题不简单，先留个记号吧

三每元 发表于 2021-11-28 14:15:38

按“发票代码”分组，将连续的“发票号码”整合，单独的“发票号码”则单独列示
发票号码08438634至08438637
这种，要计算机完全适应人，要自动化比较难
页: 1 [2] 3 4
查看完整版本: 如何快速整理发票数据