在 Excel 中添加最后一行作为列

Question

I have an excel sheet that separates the Classroom details by a blank row and name of the classroom.

I want to generate a new sheet that adds the name of the classroom selected from row tagged as classroom name as a column for each student of the class.

I have tried it multiple time but to no solution.

The image that should be edited to get to the below destination image:

Destination Image to be achievable:

I have tried the following codes but it does not work

Dim ws As Worksheet
Dim wb As Workbook

Sub Copy_data_into_master()
    Dim sno, Row1s As Integer
    Dim ws1, ws2 As Worksheet

    'Macro to copy the data into a master file
    Dim St As Variant

    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual

    On Error Resume Next
    lastCol = 0
    LastRow = 0
    sno = 0

    Set wb = ThisWorkbook
    Set ws = ThisWorkbook.Worksheets("temp")
    'Set ws2 = ThisWorkbook.Worksheets("Sheet1")
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    'Deleting current data
    'If ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row > 1 Then
    '    ws2.Range("A2:G" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row).Clear
    'End If
    sno = 0


    'Loop through each Excel file in folder

    '    For Row1s = 0 To LastRow
    '    For col1 = 0 To lastCol
    '        If ws1.Range("A1").Offset(Row1s, col1).Value = "** SUMME PSP-ELEMENT" Then
    '        'Set St = ws1.Range("A1").Offset(4, col1).Value
                Call copy_data(wb, ws)
    '        End If
    '    Next
    'Next
        'wb.Close SaveChanges:=False



    'MsgBox "Copy Complete!"

    ResetSettings:
      'Reset Macro Optimization Settings
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True

End Sub



Sub copy_data(wb1 As Workbook, ws1 As Worksheet)
    Dim ws2 As Worksheet
    Dim lastCol, LastRow As Integer
    Dim col1, row1 As Integer
    Set ws2 = Worksheets.Add
    Dim EntireRow As Range
    Dim SourceRange As Range
    Dim Nachname_col, Aufnr_col, empid_col, Text_col, Vorname_col, Ist_col, as_col As Long

    'lastCol = ws1.Cells(4, ws1.Columns.Count).End(xlToLeft).Column
    lastCol = ws1.UsedRange.Columns(ws1.UsedRange.Columns.Count).Column
    LastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    name_col = 1000
    secondname_col = 1000
    proj_col = 1000
    days_col = 1000
    rate_col = 1000
    total_col = 1000
    Fixedcost_col = 1000

    For I = SourceRange.Rows.Count To 1 Step -1
                Set EntireRow = SourceRange.Cells(I, 1).EntireRow
                If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
                    EntireRow.Delete
                End If

    With ws2.Range("A1")
        For col1 = 0 To lastCol
            If ws1.Range("A1").Offset(0, col1).Value Like "Name" Then
                Nachname_col = col1
            ElseIf ws1.Range("A1").Offset(5, col1).Value Like "Aufnr" Then
                Aufnr_col = col1
            ElseIf ws1.Range("A1").Offset(4, col1).Value Like "Text" Then
                Text_col = col1
            ElseIf ws1.Range("A1").Offset(3, col1).Value Like "Vorname" Then
                Vorname_col = col1
            ElseIf ws1.Range("A1").Offset(1, col1).Value Like "Ist" Then
                Ist_col = col1
            ElseIf ws1.Range("A1").Offset(2, col1).Value Like "as" Then
                as_col = col1
            End If
        Next col1

    '

        For row1 = 0 To LastRow - 1
    '        If ws1.Range("A1").Offset(row1, 0).Value = "* SUMME VORGANG" Then
    '            Exit For
    '        Else
    '            sno = sno + 1
                .Offset(sno, 0).Value = wb1.Name
                .Offset(sno, 1).Value = ws1.Range("A1").Offset(row1, Nachname_col).Value
                .Offset(sno, 2).Value = ws1.Range("A1").Offset(row1, Aufnr_col).Value
                .Offset(sno, 3).Value = ws1.Range("A1").Offset(row1, Text_col).Value
                .Offset(sno, 4).Value = ws1.Range("A1").Offset(row1, Vorname_col).Value
                .Offset(sno, 5).Value = ws1.Range("A1").Offset(row1, Ist_col).Value
                .Offset(sno, 6).Value = ws1.Range("A1").Offset(row1, as_col).Value


        Next row1

    End With

End Sub

The expected output sheet is attached

The code should also delete blank rows from the excel.

Answer 1

You can do this fairly simply with Power Query aka Get & Transform available in Excel 2010 and later.

• Get from Table/Range
• Add a Conditional Column and NAME it Classroom

• Select the Classroom Column and Fill Up
• Filter on Column 1 using Text <> Classroom Name

Result

M-Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", Int64.Type}, {"Column4", type any}, {"Column5", type text}, {"Column6", type number}, {"Column7", type text}}),
    #"Added Conditional Column" = Table.AddColumn(#"Changed Type", "Classroom", each if [Column1] = "Classroom Name" then [Column4] else null),
    #"Filled Up" = Table.FillUp(#"Added Conditional Column",{"Classroom"}),
    #"Filtered Rows" = Table.SelectRows(#"Filled Up", each [Column1] <> "Classroom Name")
in
    #"Filtered Rows"