Forum Discussion
AKuma0411
Dec 16, 2024Brass Contributor
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 = NothingEnd Sub
- JKPieterseSilver Contributor
Changing all formulas into values in the copy is as simple as:
newWs.UsedRange.Value = newWs.UsedRange.Value
- AKuma0411Brass Contributor
Thank you for your response. Could you please provide a more detailed explanation?
- AKuma0411Brass 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 = NothingEnd Sub