如何快速整理发票数据

绿色蔬菜种植

刘兴辉

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("输出样式")
  .[a1].CurrentRegion.Offset(1) = Empty
  .[a2].Resize(m, UBound(brr, 2)) = brr
End With
MsgBox "ok!"
End Sub

云巢

工作底稿（样式）.rar (28.63 KB, 下载次数: 15)

2021-9-30 09:12 上传

点击文件名下载附件
工作底稿（样式）.rar

钮祜禄壮壮

PQ（EXCEL2016及以上自带）解法
使用方法：发票那张表数据变化后，在结果表（输出样式表的第20-26行）数据上点击右键，选择刷新
工作底稿（样式）.zip (23.19 KB, 下载次数: 56)

2021-9-30 09:12 上传

点击文件名下载附件
工作底稿（样式）.zip

阳光遇上玻璃窗

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

彼方尚有荣光在

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

赵松林

工作底稿（样式）发票号码连续显示起至_基础vba数据透视表.rar (35.99 KB, 下载次数: 24)

2021-9-30 09:12 上传

点击文件名下载附件
工作底稿（样式）发票号码连续显示起至_基础vba数据透视表.rar
我采用的是excel2010版本的数据透视表做的，做完后删除透视表。

哥的爱很实在

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

用户怀哥

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

三每元

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