Question

我正在尝试创建一个学校成绩单，可以在输入表上输入成绩（A，B，C和D来自下拉菜单），然后将与不同学生有关的信息导出到单独的床单。

我发现这个宏（下面）用于将信息从输入表导出到工作簿中的单独工作表，但问题是它在行而不是列中工作。它采用A列中的名称（例如A3），根据该名称创建工作表，并根据您输入到模块中的范围变量，将第3行中的信息与其一起导出，以及B3，C3等。

我想要做的是从一行而不是一列获取名称，并将名称下面的名称导出到一个单独的表格中（名称是新的标题）片）。所以，正如你可以在屏幕截图中看到的那样，我的学生们可以看到。名称从D7到Q7，第一名学生的成绩从D8到D63。

[截图] [1]

我尝试将所有vcol命令更改为行命令，反之亦然，但我似乎无法对其进行调试。我对成为一名优秀的程序员非常感兴趣，但我不得不承认我基本上是一名新手。有什么建议？

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:C1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
       If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

Answer 1

虽然可能有一些＆＃34;按行过滤＆＃34;方法I采用Dictionary方法

Option Explicit

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

    Set studsSht = Worksheets("Sheet1") '<--| 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("A1") '<--| copy its columns to correspondingly named sheet starting from cell A1
        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

Answer 2

代码似乎比您的规范要求的更加漂亮，所以我在这里的答案中将其简化了一点，以使其更容易理解。第一个for循环只删除标题中的重复项（在您的情况下，如果您有多个具有相同名称的学生，则只会为该名称创建一个新表）。

因为您的用例似乎要求为您的数据中的每个学生提供唯一标识符，所以我已删除了（和相关代码）以使您更简单。下面的简单子程序可以为一定数量的学生解决您的问题。如果您计划将来扩展您的学生，那么很容易进入并使该部分变得动态，但是现在您可以在Set studentsRange = masterSheet.Range("D7:Q7")中编辑该范围，以始终对应于您的学生所在的位置。名字是。

Sub CreateIndividualReportCards()
    Dim masterSheet As Worksheet
    Set masterSheet = Sheets("Sheet1") 'This is the title of the sheet where your bulk data is
    Dim studentsRange As Range
    Set studentsRange = masterSheet.Range("D7:Q7") 'This is the range of your headings, in your case student names

    Dim i As Integer
    For i = 1 To studentsRange.Columns.Count
        If Not Evaluate("=ISREF('" & studentsRange.Cells(i) & "'!A1)") Then 'This checks to see if a sheet for the student already exists
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = studentsRange.Cells(i) & ""
        End If
        Sheets(studentsRange.Cells(i) & "").Columns.ClearContents 'In case the sheet already exists with old data, this line clears that old data and in order to repopulate with the new data from the masterSheet
        studentsRange.Cells(i).EntireColumn.Copy Sheets(studentsRange.Cells(i) & "").Range("A1") 'This copies the student's grades to the new sheet
    Next i

    masterSheet.Activate
End Sub

将信息列导出到新工作表

2 个答案: