好几天才可以复制粘贴完，那就来用一键生成询证函（增强版）

11月19日

周二

跟着卢子一起成长。...

截止下午5点，留言区排名前5名的赠送书籍Excel VBA跟卢子一起学 早做完，不加班 （基础入门版）。

关于询证函早期发过文章，只要一键就可以生成全部，省心省力，不过这个模板还不够完美。每个公司的记录可能不止一条记录，而这个模板只针对一条记录。



好，现在从头开始说明。

VIP学员的问题，要给几百家公司制作往来款项询证函，手工搞了半天才制作了几十家。全部搞完，都不知道要花费几天的时间。

目录，需要将每个公司的信息分别填写到每个细分的表格。



询证函，按照这个模板，在黄色填充色单元格引用目录相应的内容。



细分的表格，生成效果。



注：填充颜色只是为了方便说明，实际操作中，可以去掉。

需要生成的公司实在太多了，如果借助传统的复制粘贴方法，需要好几天才可以完成。你的手估计要废了。

卢子想了想，还是用VBA搞定，先来体验一键生成的爽！真的只是一瞬间，快到你不敢想象。



在使用模板的时候，有一个注意点，现在说明一下。

目录和询证函这两个工作表名称不允许改动，里面表格的内容可以根据实际需求改动。



模板下载：

https://pan.baidu.com/s/1kzumt7vncNTTCiFi4d6XLA

Sub 询证函Tos()

Dim Dic As Object, Dk, Di

Dim Mlmr As Long, Sh As Worksheet

Dim Ml_Sh As Worksheet, Xzh_Sh As Worksheet

Dim ML01 As Long, ML02 As Integer, Arr, RowCous As Integer

Set Dic = CreateObject("Scripting.Dictionary")

Set Ml_Sh = Worksheets("目录")

Set Xzh_Sh = Worksheets("询证函")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each Sh In Worksheets

If Sh.Name

"目录" And Sh.Name

"询证函" Then Sh.Delete

Next Sh

Application.DisplayAlerts = True

With Ml_Sh

Mlmr = .Cells(Rows.Count, 1).End(xlUp).Row

For ML01 = 6 To Mlmr

Dic(.Cells(ML01, 1).Value) = Dic(.Cells(ML01, 1).Value) & ML01 & "|"

Next ML01

Dk = Dic.keys

Di = Dic.items

End With

For ML01 = 0 To Dic.Count - 1

Xzh_Sh.Copy After:=Sheets(Sheets.Count)

With ActiveSheet

Arr = StrReverse(Mid(StrReverse(Di(ML01)), 2))

Arr = Split(Di(ML01), "|")

.Name = Ml_Sh.Cells(Arr(0), 2)

[d3] = Dk(ML01)

[a4] = "公司（个人)名称：" & Ml_Sh.Cells(Arr(0), 2)

Select Case UBound(Arr) - 1

    关注 Excel不加班