Loop through worksheets to copy data to new workbook

Try this slightly adjusted code….

Sub ConsolidateData()
Dim nEndRw As Long, Ws As Worksheet, nTemp As Long

Sheets.Add , Sheets(Sheets.Count)
Sheets(1).Range("B1:E1").Copy Range("A1")
ActiveSheet.Move

Application.ScreenUpdating = False

For Each Ws In ThisWorkbook.Worksheets
    With Ws
            nEndRw = .Cells(Rows.Count, "D").End(xlUp).Row
        .Range("D2:D" & nEndRw).SpecialCells(xlCellTypeConstants, 23).Copy
            nEndRw = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(nEndRw, "A").PasteSpecial xlPasteValues, , True
            nTemp = Cells(Rows.Count, "A").End(xlUp).Row
        Range("B" & nEndRw & ":B" & nTemp).Value = .Range("F2").Value
        For Each r In Range("A" & nEndRw & ":A" & nTemp)
            r.Offset(, 2).Value = r.Value & r.Offset(, 1).Value
        Next r
        Range("D" & nEndRw & ":D" & nTemp).Value = .Name
    End With
Next Ws

Range("A1").CurrentRegion.EntireColumn.AutoFit

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Glad it helps you and thanks for the feedback and rep