Question

我有一张创建学校成绩单的工作簿。在@ user3598756的帮助下，我亲切地向我介绍了Dictionary方法，现在我有了一个工作宏，用于将输入表中的信息列导出到新表。 D1到D63现在出现在D列的sheet2上，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

将模板导出到每个工作表和列以分隔工作表

1 个答案: