Forum Discussion

AKuma0411's avatar
AKuma0411
Brass Contributor
Dec 16, 2024

Assistance Needed with Macro Code Adjustments

Hello,

I request any assistance in refining a macro code I am currently working on. My requirements are as follows:

  • The code should copy data from columns AK to AS while maintaining the original formatting from the source file.
  • I need to paste this data as values in columns AK to AO and AQ to AS, while leaving column AP with formulas intact.
  • Additionally, only the following cells should contain formulas: AP4, AP5, AQ4, AQ5, AR4, and AR5.
  • Lastly, there are two logos that need to be positioned: one on the left side of the sheet and the other on the right.

Currently, the macro is copying all formulas into the new workbook instead of pasting values as intended.

I appreciate any help in making the necessary adjustments to meet these requirements. thanks!

Macro code with excel file in the attachment

Sub ExportReviewTab()
    Dim wb As Workbook
    Dim newWb As Workbook
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim exportButton As Object
    Dim saveFile As Variant
    Dim lastRow As Long
    Dim col As Integer
    Dim shp As Shape
    Dim fileName As String
    Dim currentDateTime As String

    ' Set the worksheet to export
    Set ws = ThisWorkbook.Sheets("Review")

    ' Find the last row in column AK
    lastRow = ws.Cells(ws.Rows.count, "AK").End(xlUp).Row

    ' Create a new workbook
    Set newWb = Workbooks.Add
    Set newWs = newWb.Sheets(1)
    newWs.Name = "Review" ' Rename the sheet to "Review"

    ' Copy all formatting and content (including merged cells) from the source worksheet
    ws.Range("AK1:AS" & lastRow).Copy
    newWs.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme ' This ensures all formatting, including merged cells, are copied
    newWs.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ' This ensures column widths match exactly

    ' Paste column AJ (which becomes column E in the new workbook) as values, starting from E10
    ws.Range("AK9:AK" & lastRow).Copy
    newWs.Range("E10").PasteSpecial Paste:=xlPasteValues ' Paste values to avoid #REF! error, starting from E10
    
    ' Paste values from AJ5 and AJ6 (which become E5 and E6 in the new workbook)
    newWs.Range("E4").Value = ws.Range("AO4").Value
    newWs.Range("E5").Value = ws.Range("AO5").Value

    ' Apply specific formulas in the new workbook
    newWs.Range("F9:F" & lastRow).Formula = "=IF(D9="""","""",D9*E9)"
    newWs.Range("F4").Formula = "=SUM(F9:F" & lastRow & ")"
    newWs.Range("F5").Formula = "=SUBTOTAL(109,F9:F" & lastRow & ")"
    newWs.Range("G4").Formula = "=F4-E4"
    newWs.Range("G5").Formula = "=F5-E5"
    newWs.Range("H4").Formula = "=G4/E4"
    newWs.Range("H5").Formula = "=G5/E5"

    ' Copy Picture 3 and Picture 4 from the source worksheet and position them exactly the same
    For Each shp In ws.Shapes
        If shp.Name = "Picture 3" Or shp.Name = "Picture 4" Then
            shp.Copy
            newWs.Paste
            ' Align the shape position to match the original
            With newWs.Shapes(newWs.Shapes.count)
                .Top = shp.Top
                .Right = shp.Right
                '.LockAspectRatio = shp.LockAspectRatio
                '.Width = shp.Width
                '.Height = shp.Height
            End With
        End If
    Next shp
    
     ' Delete data validation in the new worksheet cells B1:B5
    newWs.Range("B1:B5").Validation.Delete

    ' Clear contents of cells A1:A5
    newWs.Range("A1:A5").ClearContents
    newWs.Range("B1:B5").ClearContents
    
    ' Paint cells B1:B5 with no fill
    newWs.Range("B1:B5").Interior.ColorIndex = xlNone

    ' Group column J in the new worksheet
    newWs.Columns("J:J").Group

    ' Freeze panes at row 9
    newWs.Rows("9:9").Select
    ActiveWindow.FreezePanes = True
    
    ' Add a filter to row 9 (header row)
    newWs.Rows("8:8").AutoFilter

    ' Remove gridlines
    newWs.Application.ActiveWindow.DisplayGridlines = False

    ' Set zoom to 80%
    newWs.Application.ActiveWindow.Zoom = 80

    ' Move cursor to cell A1
    newWs.Range("A1").Select

    ' Apply font type to Calibri and set the font size to match source
    newWs.Cells.Font.Name = "Calibri" ' Set font explicitly to Calibri
    newWs.Cells.Font.Size = ws.Cells.Font.Size ' Keep the same font size from the source

    ' Remove export button if it exists in the original worksheet
    On Error Resume Next
    Set exportButton = ws.Buttons("Export")
    If Not exportButton Is Nothing Then
        exportButton.Delete
    End If
    On Error GoTo 0

    ' Set default file name with the current date and time
    currentDateTime = Format(Now, "yyyymmdd_HHMMSS") ' Adds timestamp to file name
    fileName = "EL_Review_" & currentDateTime

    ' Prompt to save the new workbook with the default file name
    saveFile = Application.GetSaveAsFilename(InitialFileName:=fileName, FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Exported File")
    If saveFile <> False Then
        newWb.SaveAs fileName:=saveFile
        MsgBox "File saved as: " & saveFile
    End If

    ' Script was written by abc
    newWs.Cells(lastRow + 2, 1).Value = "Script written by abc"

    ' Clean up
    Application.CutCopyMode = False
    Set newWb = Nothing
    Set newWs = Nothing
    Set ws = Nothing
End Sub

  • Sub ExportReviewTab()
        Dim wb As Workbook
        Dim newWb As Workbook
        Dim ws As Worksheet
        Dim newWs As Worksheet
        Dim exportButton As Object
        Dim saveFile As Variant
        Dim lastRow As Long
        Dim col As Integer
        Dim shp As Shape
        Dim fileName As String
        Dim currentDateTime As String

        ' Set the worksheet to export
        Set ws = ThisWorkbook.Sheets("Review")

        ' Find the last row in column AK
        lastRow = ws.Cells(ws.Rows.count, "AK").End(xlUp).Row

        ' Create a new workbook
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        newWs.Name = "Review" ' Rename the sheet to "Review"

        ' Copy all formatting and content (including merged cells) from the source worksheet
        ws.Range("AK1:AS" & lastRow).Copy
        newWs.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme ' This ensures all formatting, including merged cells, are copied
        newWs.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ' This ensures column widths match exactly

        ' Paste column AJ (which becomes column E in the new workbook) as values, starting from E10
        ws.Range("AK9:AS" & lastRow).Copy
        newWs.Range("A9").PasteSpecial Paste:=xlPasteValues ' Paste values to avoid #REF! error, starting from E10
        
        ' Paste values from AJ5 and AJ6 (which become E5 and E6 in the new workbook)
        newWs.Range("E4").Value = ws.Range("AO4").Value
        newWs.Range("E5").Value = ws.Range("AO5").Value

        ' Apply specific formulas in the new workbook
        newWs.Range("F9:F" & lastRow).Formula = "=IF(D9="""","""",D9*E9)"
        newWs.Range("F4").Formula = "=SUM(F9:F" & lastRow & ")"
        newWs.Range("F5").Formula = "=SUBTOTAL(109,F9:F" & lastRow & ")"
        newWs.Range("G4").Formula = "=F4-E4"
        newWs.Range("G5").Formula = "=F5-E5"
        newWs.Range("H4").Formula = "=G4/E4"
        newWs.Range("H5").Formula = "=G5/E5"

        ' Copy Picture 3 and Picture 4 from the source worksheet and position them exactly the same
        For Each shp In ws.Shapes
            If shp.Name = "Picture 3" Or shp.Name = "Picture 4" Then
                shp.Copy
                newWs.Paste
                ' Align the shape position to match the original
                With newWs.Shapes(newWs.Shapes.count)
                    .Top = shp.Top
                    .Right = shp.Right
                    '.LockAspectRatio = shp.LockAspectRatio
                    '.Width = shp.Width
                    '.Height = shp.Height
                End With
            End If
        Next shp
        
         ' Delete data validation in the new worksheet cells B1:B5
        newWs.Range("B1:B5").Validation.Delete

        ' Clear contents of cells A1:A5
        newWs.Range("A1:A5").ClearContents
        newWs.Range("B1:B5").ClearContents
        
        ' Paint cells B1:B5 with no fill
        newWs.Range("B1:B5").Interior.ColorIndex = xlNone

        ' Group column J in the new worksheet
        newWs.Columns("J:J").Group

        ' Freeze panes at row 9
        newWs.Rows("9:9").Select
        ActiveWindow.FreezePanes = True
        
        ' Add a filter to row 9 (header row)
        newWs.Rows("8:8").AutoFilter

        ' Remove gridlines
        newWs.Application.ActiveWindow.DisplayGridlines = False

        ' Set zoom to 80%
        newWs.Application.ActiveWindow.Zoom = 80

        ' Move cursor to cell A1
        newWs.Range("A1").Select

        ' Apply font type to Calibri and set the font size to match source
        newWs.Cells.Font.Name = "Calibri" ' Set font explicitly to Calibri
        newWs.Cells.Font.Size = ws.Cells.Font.Size ' Keep the same font size from the source

        ' Remove export button if it exists in the original worksheet
        On Error Resume Next
        Set exportButton = ws.Buttons("Export")
        If Not exportButton Is Nothing Then
            exportButton.Delete
        End If
        On Error GoTo 0

        ' Set default file name with the current date and time
        currentDateTime = Format(Now, "yyyymmdd_HHMMSS") ' Adds timestamp to file name
        fileName = "EL_Review_" & currentDateTime

        ' Prompt to save the new workbook with the default file name
        saveFile = Application.GetSaveAsFilename(InitialFileName:=fileName, FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Exported File")
        If saveFile <> False Then
            newWb.SaveAs fileName:=saveFile
            MsgBox "File saved as: " & saveFile
        End If

        ' Script was written by abc
        newWs.Cells(lastRow + 2, 1).Value = "Script written by abc"

        ' Clean up
        Application.CutCopyMode = False
        Set newWb = Nothing
        Set newWs = Nothing
        Set ws = Nothing

    End Sub

  • JKPieterse's avatar
    JKPieterse
    Silver Contributor

    Changing all formulas into values in the copy is as simple as:

    newWs.UsedRange.Value = newWs.UsedRange.Value

     

    • AKuma0411's avatar
      AKuma0411
      Brass Contributor

      Thank you for your response. Could you please provide a more detailed explanation?

      • AKuma0411's avatar
        AKuma0411
        Brass Contributor

        Sub ExportReviewTab()
            Dim wb As Workbook
            Dim newWb As Workbook
            Dim ws As Worksheet
            Dim newWs As Worksheet
            Dim exportButton As Object
            Dim saveFile As Variant
            Dim lastRow As Long
            Dim col As Integer
            Dim shp As Shape
            Dim fileName As String
            Dim currentDateTime As String

            ' Set the worksheet to export
            Set ws = ThisWorkbook.Sheets("Review")

            ' Find the last row in column AK
            lastRow = ws.Cells(ws.Rows.count, "AK").End(xlUp).Row

            ' Create a new workbook
            Set newWb = Workbooks.Add
            Set newWs = newWb.Sheets(1)
            newWs.Name = "Review" ' Rename the sheet to "Review"

            ' Copy all formatting and content (including merged cells) from the source worksheet
            ws.Range("AK1:AS" & lastRow).Copy
            newWs.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme ' This ensures all formatting, including merged cells, are copied
            newWs.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ' This ensures column widths match exactly

            ' Paste column AJ (which becomes column E in the new workbook) as values, starting from E10
            ws.Range("AK9:AS" & lastRow).Copy
            newWs.Range("A9").PasteSpecial Paste:=xlPasteValues ' Paste values to avoid #REF! error, starting from E10
            
            ' Paste values from AJ5 and AJ6 (which become E5 and E6 in the new workbook)
            newWs.Range("E4").Value = ws.Range("AO4").Value
            newWs.Range("E5").Value = ws.Range("AO5").Value

            ' Apply specific formulas in the new workbook
            newWs.Range("F9:F" & lastRow).Formula = "=IF(D9="""","""",D9*E9)"
            newWs.Range("F4").Formula = "=SUM(F9:F" & lastRow & ")"
            newWs.Range("F5").Formula = "=SUBTOTAL(109,F9:F" & lastRow & ")"
            newWs.Range("G4").Formula = "=F4-E4"
            newWs.Range("G5").Formula = "=F5-E5"
            newWs.Range("H4").Formula = "=G4/E4"
            newWs.Range("H5").Formula = "=G5/E5"

            ' Copy Picture 3 and Picture 4 from the source worksheet and position them exactly the same
            For Each shp In ws.Shapes
                If shp.Name = "Picture 3" Or shp.Name = "Picture 4" Then
                    shp.Copy
                    newWs.Paste
                    ' Align the shape position to match the original
                    With newWs.Shapes(newWs.Shapes.count)
                        .Top = shp.Top
                        .Right = shp.Right
                        '.LockAspectRatio = shp.LockAspectRatio
                        '.Width = shp.Width
                        '.Height = shp.Height
                    End With
                End If
            Next shp
            
             ' Delete data validation in the new worksheet cells B1:B5
            newWs.Range("B1:B5").Validation.Delete

            ' Clear contents of cells A1:A5
            newWs.Range("A1:A5").ClearContents
            newWs.Range("B1:B5").ClearContents
            
            ' Paint cells B1:B5 with no fill
            newWs.Range("B1:B5").Interior.ColorIndex = xlNone

            ' Group column J in the new worksheet
            newWs.Columns("J:J").Group

            ' Freeze panes at row 9
            newWs.Rows("9:9").Select
            ActiveWindow.FreezePanes = True
            
            ' Add a filter to row 9 (header row)
            newWs.Rows("8:8").AutoFilter

            ' Remove gridlines
            newWs.Application.ActiveWindow.DisplayGridlines = False

            ' Set zoom to 80%
            newWs.Application.ActiveWindow.Zoom = 80

            ' Move cursor to cell A1
            newWs.Range("A1").Select

            ' Apply font type to Calibri and set the font size to match source
            newWs.Cells.Font.Name = "Calibri" ' Set font explicitly to Calibri
            newWs.Cells.Font.Size = ws.Cells.Font.Size ' Keep the same font size from the source

            ' Remove export button if it exists in the original worksheet
            On Error Resume Next
            Set exportButton = ws.Buttons("Export")
            If Not exportButton Is Nothing Then
                exportButton.Delete
            End If
            On Error GoTo 0

            ' Set default file name with the current date and time
            currentDateTime = Format(Now, "yyyymmdd_HHMMSS") ' Adds timestamp to file name
            fileName = "EL_Review_" & currentDateTime

            ' Prompt to save the new workbook with the default file name
            saveFile = Application.GetSaveAsFilename(InitialFileName:=fileName, FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save Exported File")
            If saveFile <> False Then
                newWb.SaveAs fileName:=saveFile
                MsgBox "File saved as: " & saveFile
            End If

            ' Script was written by abc
            newWs.Cells(lastRow + 2, 1).Value = "Script written by abc"

            ' Clean up
            Application.CutCopyMode = False
            Set newWb = Nothing
            Set newWs = Nothing
            Set ws = Nothing

        End Sub

Resources