将模板导出到每个工作表和列到单独的工作表

Question

我有一本用于制作学校成绩单的工作簿。在 @user3598756 的帮助下，他向我介绍了 Dictionary 方法，我现在有了一个工作宏，用于将输入表中的信息列导出到新表中。 D1 到 D63 现在出现在 D 列的工作表 2 上，E1 到 E63 列现在出现在工作表 3 的 D 列中，依此类推（新工作表的学生姓名来自第 7 行）。代码如下：

Option Explicit

Sub parse_data()
    Dim studsSht As Worksheet
    Dim cell As Range
    Dim stud As Variant

    Set studsSht = Worksheets("Input") '<--| change "Sheet1" to your actual students grades sheet
    With CreateObject("Scripting.Dictionary") '<--| instantiate a Dictionary object
        For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through students names (change "D7:Q7" to your actual range with students names)
            .item(cell.Value) = .item(cell.Value) & cell.EntireColumn.Address(False, False) & "," '<--| add or update the dictionary entry whose key is the current student name with its corresponding column address
        Next
        For Each stud In .keys '<--| loop through unique students names
            Intersect(studsSht.UsedRange, studsSht.Range(Left(.item(stud), Len(.item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1") '<--| copy its columns to correspondingly named sheet starting from cell D1
        Next
    End With

    studsSht.Activate
End Sub

Function GetSheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = Worksheets(shtName)
    If GetSheet Is Nothing Then
        Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.count))
        GetSheet.Name = shtName
    End If
End Function

不过，我还想将输入页面的基本模板部分 (A1:C63) 复制到 每个 新工作表中，并且在同一个宏中。虽然有许多宏可以复制基本模板，但我发现很难集成它们。通过反复试验，我得到了喜忧参半的结果；一个新的学生页面同时包含模板和学生数据，其余的只有学生数据（前三列为空白），或者一堆额外的仅包含模板的不必要的工作表。

上面的宏可以很好地创建一个新工作表，只有在输入工作表的第 7 行中存在学生姓名的情况下（因此我不必为具有更少或更多学生的输入工作表编辑宏）。我希望将前三列转置的宏的新部分对该功能做出反应，这就是我被卡住的地方。

对新手有什么建议吗？

Answer 1

您应该能够将它包含在您的 GetSheet 函数中（我假设您希望它在每个工作表的相同位置）：

Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
If GetSheet Is Nothing Then
    Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.count))
    GetSheet.Name = shtName
    Sheets("Sheet1").Range("A1:C63").Copy
    GetSheet.Range("A1").PasteSpecial xlAll
End If
End Function