Экспорт COLUMNS информации на новые листы

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

хотя может быть какой-то способ «Фильтр по строкам» Я бы с 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