Excel VBA 电子发票管理助手/电子发票登记管理系统（EXCEL版）

本文于2023年6月15日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

☆本期内容概要☆

• 发票小助手重磅更新
• 发票标志重复记录
• 发票删除重复记录
• 发票文件归档

大家好，我是冷水泡茶，前几天我们分享了2篇电子发票信息读取的文章（Excel VBA 应用案例分享/电子发票管理小助手/电子发票信息读取）以及（Excel VBA 应用案例分享/电子发票管理助手/电子发票信息读取/更新、补充、使用说明），我的本意是分享EXCEL读取PDF、XML方法与思路，但后来发现感兴趣的人很多，我感觉心里有点不踏实了，我估计有很多人是要拿去实际应用了。

思来想去，还是决定再进一步完善，让在工作中使用它的朋友能更方便，数据更准确一些。

一、发票信息读取

首先，我们要增加PDF文件读取的准确性，由于是通过Acrobat Pro转成Word再进行文本提取，对于不同版式的发票，我们取得的待提取文件差异较大，所以必须多找一些发票来测试。

于是我用它来读取公司的一些发票，300张发票，搞了大概1~2个小时，具体记不清了，反正速度不太理想，当然，日常使用也不会一次读取这么多的发票。

读取结果还是不错的，大多都能正确读取（以信息读取完全为标准，实际准确性待验证）。

最近一段时间，把读取不完整的发票再分别情况更新代码：

1、PDF格式：检查wordcontent，然后更新正则表达式。有些发票它转成WORD全是乱码，或者干脆转换不了，这样的发票就没有办法了，除非以后调整PDF文件的读取方式，目前这种方法真的只能两手一摊......

2、OFD格式：调整取数方式与逻辑

（1）对于旧版“XX增值税电子普通发票”，原来是从解压出来的Attachs文件夹下的original_invoice.xml文件中提取数据，但由于新的电子发票没有这个Attachs文件夹，所以统一从Doc_0PagesPage_0Content.xml中取数。

（2）主节点的ID各有不同，其下items的节点ID也不尽相同，需要分别处理。

layerID = xmlD.SelectSingleNode("/ofd:Page/ofd:Content/ofd:Layer/@ID").Text

（A）电子发票（普通发票），ID=6955或6947

（B）电子发票（普通发票）_货物运输服务，ID=6989

（C）XX增值税电子普通发票，ID=60

（D）其他格式的发票没有样本，未知，碰到再说。

（3）对于金额、税额、价税合计，由于同样的版式它的节点ID都有不一样的，比较难搞，最后分析节点发现在每个合计金额前都有一个“￥”，然后通过循环节点的方式定位“￥”符号，取其下一个节点的金额。这里还有个小陷阱，就是这个“￥”，直接输入这个符号却不能定位到XML中的“￥”符号，得用编码ChrW(165) 来表示“￥”，方才识别成功。

这里取得数据后，存到数组，考虑到免税等异情况下，税额可能不是数字，所以把取得的节点text转换成Double类型，然后排序，取最大值为价税合计，第二大值为金额，两者相减为税额。

（4）对于开票项目，查找包含2个“*”的节点，如果有多个明细项目，则会全部取出，以“”号隔开。这里还要考虑密码区有“*”的情况，给开票项目限定了一个长度。

二、调整代码结构，把共同的代码块改为独立的过程，再调用。

三、增加功能：

1、结果表Result增加表头字段：

（1）归档文件：把发票文件以发票代码+“_”+发票号码的形式命名保存在归档文件夹下。

（2）电子票号 ：发票代码+“_”+发票号码，便于查重

（3）登记日期：增加登记日期字段，便于管理，也可以考虑增加报销日期或记账日期，跟财务月份相对应。

2、发票查重：把所有重复的发票标上颜色，第一条灰色，第二条绿色，第三条蓝色......

Sub HighlightDuplicateRecords() '重复值标色 Dim ws As Worksheet Dim lastRow As Long, lastColumn As Long Dim colorIndex As Integer Dim arr(), tbTitle() ThisWorkbook.Activate Set ws = ThisWorkbook.Sheets("Result") 'lastRow = ws.Cells(ws.Rows.count, "D").End(xlUp).Row ws.Activate lastRow = ws.UsedRange.Rows.count lastColumn = ws.UsedRange.Columns.count arr = ws.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Value ws.Range(Cells(2, 1), Cells(lastRow, lastColumn)).Interior.Color = vbWhite For i = 1 To lastColumn ReDim Preserve tbTitle(k) tbTitle(k) = arr(1, i) k = k + 1 Next '标记重复记录 Dim pickedRows As String For i = 2 To lastRow If InStr(pickedRows, "" & i & "") = 0 Then colorIndex = 1 key1 = arr(i, Pxy(tbTitle, "电子票号")) For j = i + 1 To lastRow key2 = arr(j, Pxy(tbTitle, "电子票号")) If key2 = key1 Then ws.Range(Cells(i, 1), Cells(i, lastColumn)).Interior.Color = PickColor(0) ws.Range(Cells(j, 1), Cells(j, lastColumn)).Interior.Color = PickColor(colorIndex) pickedRows = pickedRows & "" & j & "" colorIndex = colorIndex + 1 End If Next End If Next ' MsgBox "查重结束！所有【发票代码+发号码】重复的已标色，无重复的为白色！" End Sub

代码解析：

（1）把“Result”表内容读入数组arr()，再把表头读入数组tbTitle()，用于定位表头字段。我还是习惯用数组来处理数据。

（2）通过双层循环，比较电子票号，把重复值标色并把第二个起的重复值记到pickedRows 字段里，在下次循环的时候跳过它。每找到一个重复记录，颜色代码colorIndex +1，这样每条重复的记录都给标上不同的颜色。这里自定义一个根据数字变化取不同颜色的函数：PickColor(index )

（3）最后一条代码是MsgBox，作为查重结束以后的提示，但由于我们在读取一张发票结束后会调用查重过程，MsgBox就不适合了，特别是批量读取的时候。可以给它一个参数，TRUE or False来决定是否显示MsgBox，但觉得没有太大意义，就算了，直接注释掉拉倒。

3、发票删除重复记录：把“Result”表中重复的记录删除，只留一条最早登记的记录，本来想搞一个选择保留最新、最旧记录的，由于时间关系，没有弄，实际上应该是保留最旧的记录，后来的记录都是重复的。

Sub DeleteDuplicateRecords() '删除重复 Dim ws As Worksheet, destSheet As Worksheet Dim lastRow As Long, lastColumn As Long Dim colorIndex As Integer Dim arr(), tbTitle() Dim destRow As Integer If Not wContinue("即将删除重复记录，此操作不可恢复，请确认！") Then Exit Sub ThisWorkbook.Activate Set ws = ThisWorkbook.Sheets("Result") ws.Activate lastRow = ws.UsedRange.Rows.count lastColumn = ws.UsedRange.Columns.count arr = ws.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Value ws.Range(Cells(2, 1), Cells(lastRow, lastColumn)).Interior.Color = vbWhite For i = 1 To lastColumn ReDim Preserve tbTitle(k) tbTitle(k) = arr(1, i) k = k + 1 Next '标记重复记录 Dim pickedRows As String For i = 2 To lastRow If InStr(pickedRows, "" & i & "") = 0 Then key1 = arr(i, Pxy(tbTitle, "电子票号")) For j = i + 1 To lastRow key2 = arr(j, Pxy(tbTitle, "电子票号")) If key2 = key1 Then pickedRows = pickedRows & "" & j & "" End If Next End If Next ' 创建 "Duplicate" 工作表 On Error Resume Next Set destSheet = ThisWorkbook.Worksheets("Duplicate") On Error GoTo 0 If destSheet Is Nothing Then ' 创建新的工作表 Set sht = ThisWorkbook.Worksheets.Add sht.Name = "Duplicate" Set destSheet = sht End If destRow = destSheet.UsedRange.Rows.count For i = lastRow To 2 Step -1 k = InStr(pickedRows, "" & i & "") If InStr(pickedRows, "" & i & "") > 0 Then ws.Rows(i).Copy Destination:=destSheet.Cells(destRow, 1) destRow = destRow + 1 ' ws.Rows(i).Delete End If Next Call DeleteEmptyRows(destSheet) ws.Activate End Sub

代码解析：

（1）在查重代码的基础上，取得重复记录所在行号，pickedRows，它是以“”把每个行号隔开。

（2）检查有没有表“Duplicate”，没有就创建。

（3）从下往上循环，把行号在pickedRows中的记录先复制到“Duplicate”表中，以防万一删除错了可以找回来。

（4）删除重复值。

（5）调用DeleteEmptyRows过程删除空白行。

4、发票文件归档，我们读取发票的文件夹可以是任意文件夹，并且它们的发票文件名是各种各样的，我们要把它统一以发票代码+发票号码的形式重命名并保存到我们指定的文件夹下（Sheets(“Main“),D13单元格。

If Not IsFileExists(destInvoiceFile) Then FileCopy currInvoiceFile, destInvoiceFile End If

代码很简单，destInvoiceFile是按我们的命名规则定义的新的发票文件名。先检查存不存在此发票文件，如果不存在，则把当前读取的发票文件复制为destInvoiceFile。

另外，如果是新电子发票20位发票号码的，我们也处理成12位代码加上“_“再加上8位号码。

有些财政电子票据，它的代码8位、号码10位，与税务发票不一致，我们这样处理：把代码后面补2个0,再加上号码前2位，号码取后8位。

5、在归档文件单元格，写入发票文件名（destInvoiceFile），并加上超级链接。如果我们更改了发票存放路径，我们会把发票文件移动到新的文件夹下，并更新超级链接。

Private Sub CmdFolder_Click() Dim folder As String Dim oldfolder As String oldfolder = Sheets("Main").Range("D13") folder = FolderSelected If folder <> "" Then Range("D13") = folder Else MsgBox "未选择文件夹!" Exit Sub End If Call MoveFilesInFolder(oldfolder, folder) Call updateHyperlinks End Sub Sub updateHyperlinks() Dim ws As Worksheet Dim iCol As Integer Dim lastRow As Integer, lastCol As Integer Dim folder As String Dim invoiceFile As String Dim rng As Range Dim newFile As String folder = Sheets("Main").Range("D13").Value Set ws = Sheets("Result") lastRow = ws.UsedRange.Rows.Count lastCol = ws.UsedRange.Columns.Count ws.Activate For i = 1 To lastCol If Cells(1, i) = "归档文件" Then iCol = i Exit For End If Next With ws For i = 2 To lastRow Set rng = .Cells(i, iCol) If rng <> "" Then invoiceFile = Right(rng, Len(rng) - InStrRev(rng, "")) newFile = folder & "" & invoiceFile .Hyperlinks.Add Anchor:=rng, _ Address:=newFile, _ TextToDisplay:=newFile End If Next End With End Sub Sub MoveFilesInFolder(ByVal SourceFolder As String, ByVal DestinationFolder As String) Dim FileSystem As Object Dim SourceFile As Object Dim destFile As String '确保源文件夹和目标文件夹存在 If Dir(SourceFolder, vbDirectory) = "" Then MsgBox "源文件夹不存在！", vbExclamation Exit Sub End If If Dir(DestinationFolder, vbDirectory) = "" Then MsgBox "目标文件夹不存在！", vbExclamation Exit Sub End If '创建文件系统对象 Set FileSystem = CreateObject("Scripting.FileSystemObject") '获取源文件夹下的所有文件 For Each SourceFile In FileSystem.GetFolder(SourceFolder).Files destFile = DestinationFolder & "" & SourceFile.Name If Not IsFileExists(destFile) Then '移动文件 FileSystem.MoveFile SourceFile.Path, destFile End If Next End Sub

代码解析：移动文件、更新链接都做成了单独的过程。

6、在workbook_open事件中，添加检查发票文件夹的代码，如果文件夹不存在则给出提示。

Private Sub Workbook_Open() If Not IsFolderExists(Sheets("Main").Range("D13")) Then MsgBox "请选择发票文件归档文件夹！" End If End Sub

这次更新的改动比较大，功能也更全面了，如果作为一个小企业的财务，发票都是到财务这里统一登记的，那么今天的电子发票登记管理系统（EXCEL版）将会极大的解放你的生产力。

好，今天就这样吧。欢迎点赞、留言、分享，谢谢大家，我们下期再会。

☆猜你喜欢☆

本文于2023年6月15日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！