Copy and paste each Sheet as paste special values and retaining same format

[howard]

I have VBA Code below to copy each sheet Range A1 to H500 and paste as values and retaining same format

The code runs very slow (There are 12 sheets)

Kindly amend my code to run faster

 Sub CopySpecificRangeAndPasteAsValues()
    Dim ws As Worksheet
    Dim originalCalculationMode As XlCalculation
    Dim sourceRange As Range, targetRange As Range
    
    ' Set the source range you want to copy (A1 to H500)
    Set sourceRange = ThisWorkbook.Sheets(1).Range("A1:H500") ' Adjust the sheet index if needed
    
    ' Disable Excel features to improve speed
    Application.ScreenUpdating = False
    originalCalculationMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' Loop through all sheets in the current workbook
    For Each ws In ThisWorkbook.Sheets
        ' Set the target range in the current sheet (A1 to H500)
        Set targetRange = ws.Range("A1:H500")
        
        ' Copy and paste values while retaining the same format, cell by cell
        Dim sourceCell As Range, targetCell As Range
        For Each sourceCell In sourceRange
            Set targetCell = targetRange.Cells(sourceCell.Row, sourceCell.Column)
            sourceCell.Copy
            targetCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Next sourceCell
    Next ws
    
    ' Re-enable Excel features and reset calculation mode
    Application.CutCopyMode = False ' Clear the clipboard
    Application.EnableEvents = True
    Application.Calculation = originalCalculationMode
    Application.ScreenUpdating = True
End Sub

Your assistance is most appreciated

 

[kevin9999]

Hi Howard,
Your code is a little strange - you seem to be copying the values from sheet(1) over the top of themselves as well as to all other sheets. I'm assuming you only want to copy to sheet 2 onwards in the following code:

Option Explicit
Sub CopySpecificRangeAndPasteAsValues_V2()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws As Worksheet, sourceRange As Range, targetcell As Range, i As Long
    
    'Get the data from the first sheet
    Set sourceRange = ThisWorkbook.Worksheets(1).Range("A1:H500")
    
    'Copy to all sheets from sheet 2 onwards
    For i = 2 To ThisWorkbook.Worksheets.Count
        Set targetcell = Worksheets(i).Range("A1")
            sourceRange.Copy
            With targetcell
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
            Application.CutCopyMode = False
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

 

[howard]

Hi Kevin


Thanks for the help. I have formulas on each of the sheet and want each sheet from sheet1 to last sheet to be copied and pasted as values on each sheet for eg sheet1 to be copied and pasted as values but to retain the format, sheet2 to be copied and pasted as values etc for range A1 to H500

 

[kevin9999]

Thanks Howard, see if this does what you want:

Option Explicit
Sub CopySpecificRangeAndPasteAsValues_V3()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws As Worksheet, sourceRange As Range, targetcell As Range, i As Long
    
    'Get the data from the first sheet
    Set sourceRange = ThisWorkbook.Worksheets(1).Range("A1:H500")
    
    'Convert formulas to values
    For i = 1 To ThisWorkbook.Worksheets.Count
        Set sourceRange = Worksheets(i).Range("A1:H500")
        Set targetcell = Worksheets(i).Range("A1")
            sourceRange.Copy
            With targetcell
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
            Application.CutCopyMode = False
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

You can also remove the first Set sourceRange, the one after the 'Get the data from the first sheet.

 

[howard]

This is perfect Kevin-Many thanks for the help