Macro running slowly, copy/paste values only from one workbook to another

I created a macro that will copy all the worksheets from one workbook and save as values only into another workbook. It works, but it is a little slow. I am doing some looping and wondering if maybe I can consolidate some of the code to make the macro work more efficiently. Thank you in advance for your help.

Please find the code here:

Sub PoolSheetValuesOnly()
' Created by:   Jeanette White
' Last revised: 020311
' Purpose:      To create Pool Sheets as values only

     Dim ws As Worksheet
     Dim ws_Count As Integer
          
     'Loop through all of the worksheets in the active workbook
     For Each ws In Worksheets
        'count the number of worksheets
        ws_Count = Worksheets.Count
        For i = 1 To ws_Count
            'copy the worksheet name to cell D1
            ws.Cells(1, 4).Value = ws.Name
        Next i
     Next
        
    'Loop through all of the worksheets and select each worksheet
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    For Each ws In Worksheets
        With ws
            If .Visible = True Then .Select Replace:=False
        End With
    Next ws
    
    'copy the data
    Cells.Select
    Selection.Copy
    
    'Open a new workbook
    Workbooks.Add
    
    'add worksheets to the new workbook based on the count of the original number of worksheets
    If ws_Count > 0 Then
        For i = -1 To ws_Count
            Sheets.Add After:=Sheets(Sheets.Count)
        Next i
    End If
    
    'make sure to be on the first workbook
    Sheets("Sheet1").Select
    Range("A1").Select
    
    'Paste special values only
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    'remove any blank worksheets
    'turn the alert off
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Worksheets.Count > 1 Then
            If IsEmpty(ws.UsedRange) Then
                ws.Delete
            End If
        End If
    Next ws
    'turn the alerts on
    Application.DisplayAlerts = True
    
    'loop through and name the new worksheets based on the value in the holding cell
    For Each ws In Worksheets
        ws.Name = ws.Cells(1, 4).Value
    Next
    
    'loop through and remove the worksheet name from the holding cell
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    For Each ws In Worksheets
        With ws
            If .Visible = True Then .Select Replace:=False
            Range("D1").Select
            Selection.ClearContents
        End With
    Next ws
End Sub