exel VBA拆分工作表

Posted 2020-11-20 conjury

　　客户经理每个月要拜访很多客户，公司要求必须要一个拜访记录汇总表并且要做一个拜访客户的分表，以便主管抽查，表的结构如图一。这个时候如果一个客户一个客户填的话就很烦很耗时间。我们可以做一个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了。