新しい用紙に情報のコラムをエクスポートする

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ループは単に見出しの重複を削除します（同じ名前の学生が複数いる場合はその名前の新しいシートを1つだけ作成します）。

あなたのユースケースでは、あなたのデータ内の各生徒の固有の識別子が必要と思われるので、それを削除してよりシンプルにしました。下の簡単なサブルーチンは、設定された数の生徒の問題を解決するはずです。将来的に学生を拡大する予定がある場合は、その部分を動的にすることは簡単ですが、今のところ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