vba练习3

需求

将每一位客户生成一张excel表

数据源

代码

Sub 批量生成()

    Dim i, j, Title1
    
    i = 2
    '以 模板 表开始
    Sheets("模板").Select
    
    Do While Sheets("数据源").Range("a" & i) <> ""
        '合并单元格
        Title1 = "大赛报名表（类别：" & Sheets("数据源").Range("c" & i) & "）"
        Sheets("模板").Range("b2") = Title1
        
        With Sheets("数据源")
            .Range("d" & i).Copy
                Sheets("模板").Range("c4").PasteSpecial xlPasteValues
            .Range("e" & i).Copy
                Sheets("模板").Range("e4").PasteSpecial xlPasteValues
            .Range("f" & i).Copy
                Sheets("模板").Range("g4").PasteSpecial xlPasteValues
            .Range("g" & i).Copy
                Sheets("模板").Range("c5").PasteSpecial xlPasteValues
            
            '合并单元格
            Sheets("模板").Range("e5") = .Range("h" & i).Value
            
            '合并单元格
            Sheets("模板").Range("b8") = .Range("i" & i).Value
            
            .Range("j" & i).Copy
            Sheets("模板").Range("c6").PasteSpecial xlPasteValues
            .Range("k" & i).Copy
            Sheets("模板").Range("e6").PasteSpecial xlPasteValues
            .Range("l" & i).Copy
            Sheets("模板").Range("g6").PasteSpecial xlPasteValues
            .Range("m" & i).Copy
            Sheets("模板").Range("c7").PasteSpecial xlPasteValues
            
            '合并单元格
            Sheets("模板").Range("e7") = .Range("n" & i).Value
            
            '合并单元格
            Sheets("模板").Range("b9") = .Range("o" & i).Value
        End With
        i = i + 1
        
        '另存为  将工作表保存为工作簿
        ActiveSheet.Copy
        ActiveWorkbook.SaveAs Filename:="C:\Users\yons\Desktop\批量生成\申请表存放\" & i - 1 & ".xlsx"
        ActiveWorkbook.Close
    Loop
        
End Sub

代码有点冗余，有待加强
另外其实用邮件合并的方法更加便利

结果