Loop through worksheets to copy data to new workbook

Try the below code…

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

Sheets.Add
ActiveSheet.Move
Sheet1.Range("A1:D1").Copy Range("A1")

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

Application.ScreenUpdating = True

End Sub