客户经理每个月要拜访很多客户，公司要求必须要一个拜访记录汇总表并且要做一个拜访客户的分表，以便主管抽查，表的结构如图一。这个时候如果一个客户一个客户填的话就很烦很耗时间。我们可以做一个VBA按钮，每个月只要把汇总部分填好后，只要点击一下该按钮，就自动生成和客户信息的分表，省力又省心。
图一
先贴代码：
Sub cfsheet() Dim rng As Range, sht As Worksheet Set rng = Application.InputBox("请选择需要拆分的列", "拆分另存为工作表...", , , , , , 8) Set sht = rng.Parent ‘获取工作表名称 With sht rng.EntireColumn.Copy [az1] Range("az:az").RemoveDuplicates (1) End With ‘删除工作表 Application.DisplayAlerts = False For i = Sheets.Count To 3 Step -1 Sheets(i).Delete Next Application.DisplayAlerts = True ‘新建工作表 Application.ScreenUpdating = False rw = [az1000].End(3).Row For i = 2 To rw shtName = sht.Range("az" & i).Value Sheets.Add(after:=Sheets(Sheets.Count)).Name = shtName Sheets("拜访记录表").Activate Cells.Copy Sheets(i + 1).[a1] Sheets(i + 1).Range("b2") = Sheets("汇总表").Range("a" & i) Sheets(i + 1).Range("d2") = Sheets("汇总表").Range("b" & i) Sheets(i + 1).Range("b3") = Sheets("汇总表").Range("c" & i) Sheets(i + 1).Range("d3") = Sheets("汇总表").Range("d" & i) Sheets(i + 1).Range("b4") = Sheets("汇总表").Range("e" & i) Sheets(i + 1).Range("b5") = Sheets("汇总表").Range("f" & i) Sheets(i + 1).Range("b6") = Sheets("汇总表").Range("g" & i) Sheets(i + 1).Range("b7") = Sheets("汇总表").Range("h" & i) Sheets(i + 1).Range("b8") = Sheets("汇总表").Range("i" & i) Next Application.ScreenUpdating = True Sheets("汇总表").Range("az:az").Clear End Sub
把代码导出为加载项，再添加到工具栏，每个月就只须一点报表就OK了。
原文：https://www.cnblogs.com/conjury/p/9226729.html