Make 1 list of names out of multiple using VBA

[VikingLink]

For a school trip, I need to be able to make 1 long list with all pupils. I'd like it to feature their first name in column A, their last name in column B and their class in column C.
My starting point is one excel file with a separate sheet per class, their class name at the top and their complete name in a single cell, with their last name first and their first name last. (See example below).

I managed to find some formules to separate out their names and class (=TRIM(RIGHT(SUBSTITUTE(B5;" ";REPT(" ";LEN(B5)));LEN(B5))) for their first name, =LEFT(B5;FIND("[";SUBSTITUTE(B5;" ";"[";LEN(B5)-LEN(SUBSTITUTE(B5;" ";""))))-1) for their last name, and =TRIM(RIGHT(SUBSTITUTE($A$1;" ";REPT(" ";LEN($A$1)));LEN($A$1))) for their class). I placed this formula in cells C5 to C7, and then dragged them down.

To get them into one list, I use the following VBA, which seems to work.

Sub Copy_Range_From_Sheets()
'Modified  10/12/2021  6:36:48 PM  EDT
On Error GoTo M
Application.ScreenUpdating = False
Dim i As Long
Dim ans As String
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = 6

For i = 2 To Lastrow
    ans = Sheets("Master").Cells(i, 1).Value
   
    With Sheets(ans)
        .Range("C5:E35").Copy
        Sheets("Summary").Cells(Lastrowa, 1).PasteSpecial xlPasteValues
        Lastrowa = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row + 1
    End With
Next
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "You tried to use a sheet name that does not exist" & vbNewLine & "Or we had another problem"
Application.ScreenUpdating = True
End Sub

The problem is, that as I have 15 classes, it's a tedious job to copy the formulas and drag them down through the column for every pupil, so I was looking for a VBA to copy this formula to all 15 sheets, and drag it until the end of the list of pupils. I ran into an issue with this, as the " " in the formulas keeps giving me an error message.

Can someone help me with a VBA that will copy the formulas into all sheets (except for the Master sheet and the Summary sheet) and drag it down to get every pupil's name? The class sheets are always the same, the only thing that changes is the amount of pupils. This is normally limited to 26.

 

[NoSparks]

try this on a copy of your workbook

Sub PupilsToSummary()
    Dim sht As Worksheet
    Dim lr As Long
    Dim arr As Variant
    
Application.ScreenUpdating = False

For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> "Master" And sht.Name <> "Summary" Then
        With sht
            lr = .Range("B" & .Rows.Count).End(xlUp).Row
            'put in formulas
            .Cells(5, "C").FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[-1];"" "";REPT("" "";LEN(RC[-1])));LEN(RC[-1])))"
            .Cells(5, "D").FormulaR1C1 = "=LEFT(RC[-2];FIND(""["",SUBSTITUTE(RC[-2];"" "";""["";LEN(RC[-2])-LEN(SUBSTITUTE(RC[-2];"" "";""""))))-1)"
            .Cells(5, "E").FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(R1C1;"" "";REPT("" "";LEN(R1C1)));LEN(R1C1)))"
            'fill down
            .Range("C5:E5").AutoFill Destination:=.Range("C5:E" & lr)
            ' for copy to summary
            arr = .Range("C5:E" & lr).Value
        End With
        ' copy to Summary sheet
        With Sheets("Summary")
            .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr), 3) = arr
        End With
    End If
Next sht

Application.ScreenUpdating = True

End Sub

 

[VikingLink]

I'm getting a runtime error 1004: application-defined or object defined error. When clicking debug it highlights the entire line of the first formula that needs to be copied.

Needless to say, I'm in over my head

 

[NoSparks]

OKay, try #2

Sub PupilsToSummary()
    Dim sht As Worksheet
    Dim lr As Long
    Dim arr As Variant
    
Application.ScreenUpdating = False

For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> "Master" And sht.Name <> "Summary" Then
        Set sht = Sheets(sht.Name)
        With sht
            lr = .Range("B" & .Rows.Count).End(xlUp).Row
            'put in formulas
            .Cells(5, "C").FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[-1];"" "";REPT("" "";LEN(RC[-1])));LEN(RC[-1])))"
            .Cells(5, "D").FormulaR1C1 = "=LEFT(RC[-2];FIND(""["";SUBSTITUTE(RC[-2];"" "";""["";LEN(RC[-2])-LEN(SUBSTITUTE(RC[-2];"" "";""""))))-1)"
            .Cells(5, "E").FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(R1C1;"" "";REPT("" "";LEN(R1C1)));LEN(R1C1)))"
            'fill down
            .Range("C5:E5").AutoFill Destination:=.Range("C5:E" & lr)
            ' for copy to summary
            arr = .Range("C5:E" & lr).Value
        End With
        ' copy to Summary sheet
        With Sheets("Summary")
            .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr), 3) = arr
        End With
    End If
Next sht

Application.ScreenUpdating = True

End Sub

 

[VikingLink]

Exactly the same notification, and the same line of code gets highlighted.

 

[NoSparks]

It works for me.
Here is my test file
Going by the formulas you've shown your Excel uses ; separators whereas mine uses ,
so you'll need to go into the code and comment out mine and uncomment yours for the formulas.

 

[VikingLink]

I downloaded your file, copied the macro as it is written there, pasted it in my file, and it works fine. Thanks!
Glad this worked, because I wasn't sure on what to do when you say comment and uncomment. Maybe I should find an Excel 1-on-1 basics course

 

[NoSparks]

You are welcome, glad we got it working.

 

[VikingLink]

I tried to add one more thing to this file. Remove trailing and leading spaces from the original names, as this leads to malfunctioning formulas.
Using your code as a basis, I tried to get this to work on all sheets except for the summary one. Yet I'm missing something, as it doesn't work properly.

This is what I tried.
Do you see what I'm doing wrong?

Sub example_TRIM()
 Dim sht As Worksheet
 
 Application.ScreenUpdating = False
 
For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> "Master" And sht.Name <> "Summary" Then
        Set sht = Sheets(sht.Name)
        With sht
        
    
Dim Rng As Range
Range("B5:B35").Select
Set Rng = Selection
For Each Cell In Rng
Cell.Value = Trim(Cell)
Next Cell

         End With
    End If
Next sht

Application.ScreenUpdating = True
End Sub

 

[NoSparks]

Hello VikingLink,
A couple of things here

1) you can only select a range on a sheet that is the active sheet (ie: the one you're looking at)
and very seldom do you actually need to select anything.

2) The worksheet TRIM and the VBA TRIM functions aren't quite the same
..the VBA TRIM removes spaces from the ends only
... the worksheet TRIM function also reduces multiple spaces within the text down to a single space.

Here is how I would do it

Sub TRIM_The_Names()
 Dim sht As Worksheet
 Dim Rng As Range, cel As Range
 
 Application.ScreenUpdating = False
 
For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> "Master" And sht.Name <> "Summary" Then
        Set sht = Sheets(sht.Name)
        With sht
            Set Rng = .Range("B5:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
            For Each cel In Rng
                cel.Value = Application.WorksheetFunction.Trim(cel.Value)
            Next cel
        End With
    End If
Next sht

Application.ScreenUpdating = True
End Sub