To amend the failing fieldname in column A:
Sub M_snb()
Sheet1.Cells(1) = "Name"
sn = Sheet1.Cells(1).CurrentRegion.Rows(1)
c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""
c01 = "`" & Sheet1.Name & "$`"
For j = 4 To UBound(sn, 2)
With CreateObject("ADODB.Recordset")
.Open "Select `" & Join(Array(sn(1, 1), sn(1, 2), sn(1, 3)), "`,`") & "`, """ & sn(1, j) & """, `" & sn(1, j) & "` from " & c01, c00
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
End With
Next
Sheet2.UsedRange.Sort Sheet2.UsedRange.Cells(1)
Sheet2.UsedRange.Offset(-1).Resize(1) = Array(sn(1, 1), sn(1, 2), sn(1, 3), "course", "yes/no")
End Sub