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

I get an error in the following block (Red Font) when I run the code. Also, I can't see where the code is opening a new workbook to copy the worksheets too.

ReDim Preserve SheetsCopy(UBound(SheetsCopy) - 1)
    Sheets(SheetsCopy).Copy
    'loop through and name the new worksheets based on the value in the holding cell
    For Each ws In ActiveWorkbook.Worksheets
        ws.Name = ws.Cells(1, 4).Value
        ws.Range("D1").Clear
    Next

Moderator please mark as solved

I set application.ScreenUpdating to false at the beginning of my code and it solved the problem.

Sub PoolSheetValuesOnly()
' Created by:   Jeanette White
' Last revised: 021011
' Purpose:      To create worksheets as values only

    'stop screen flickering
    Application.ScreenUpdating = False

     'if the personal workbook is open hide it
    If Windows("PERSONAL.XLSB").Visible Then
        Windows("PERSONAL.XLSB").Visible = False
    End If
                
    'Loop through all of the worksheets and select each worksheet
    Dim ws As Worksheet
    Dim ws_Count As Integer
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    For Each ws In Worksheets
        With ws
            If .Visible = True Then .Select Replace:=False
            '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
        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 worksheet
    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 name 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
    
    'go back to orginal spreadsheet
    ActiveWindow.ActivatePrevious
    
    '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
    
    'go back to orginal spreadsheet
    ActiveWindow.ActivatePrevious
    Application.ScreenUpdating = True
End Sub

Hi I used this Macro and it worked fine in Excel versions prior to 2007 and for some reason there are errors popping up in excel 2007 version. Has anyone encountered the same and if yes do you know what the fix is. Any help here would be much appreciated.

Error Description - Method 'Undo' of object'_Application' failed
Procedure: modcopypaste.MakeUndo

Cheers
Prad

Hi,

Following macro is running slowly (30 minutes). I have to copy paste several rows from each drop down box to new worksheet. However, each time calculations have to be made to get data for each drop down list member (there are about 760 members). I am sending the code below. Is there any way to make it work faster with alternative codes.

Thanks

Sub AllCounties()
'
' AllCounties Macro
'
'
    For Counter = 21 To 785
        Set curCell = Sheet7.Cells(Counter, 1)
        curCell.Copy Destination:=Sheet2.Range("C2")
        Application.CutCopyMode = False
        Dim Zeile As Long
        Zeile = ((Counter - 21) * 1)
        Sheet2.Range("e81:I81").Copy
        Sheet1.Cells((Zeile + 3), 2).PasteSpecial xlPasteValues
        Sheet2.Range("e92:I92").Copy
        Sheet1.Cells((Zeile + 3), 7).PasteSpecial xlPasteValues
        Sheet2.Range("e103:I103").Copy
        Sheet1.Cells((Zeile + 3), 12).PasteSpecial xlPasteValues
        Sheet2.Range("e125:I125").Copy
        Sheet1.Cells((Zeile + 3), 17).PasteSpecial xlPasteValues
        Sheet2.Range("C2").Copy
        Sheet1.Cells((Zeile + 3), 1).PasteSpecial xlPasteValues
                   
     Next Counter
   
     Sheet2.Activate
     
     Sheet2.Range("C2").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=CountiesStates"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = vbNullString
        .ErrorTitle = vbNullString
        .InputMessage = vbNullString
        .ErrorMessage = vbNullString
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Hi Arlette,

Thanks for your reply, I added new thread.