The code from this forum is what I used as a starting point. I am trying to modify it to copy multiple sheets and paste them all as values, instead of just one sheet.
I copied multiple sheets using worksheets(array(1,2,3)).copy. I think the problem is With ActiveSheet.UsedRange because it is only replacing the first sheet as values and leaving the remaining sheets as formulas.
What do I need to change so that all the sheets paste as values?
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Worksheets(Array("Sheet 1","Sheet 2","Sheet 3").Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
Set wbNew = ActiveWorkbook
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
End Sub
You need to loop through the sheets:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Value = ws.UsedRange.Value
Next ws
So, with your code, you could do it like this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wbOld As Workbook, wbNew As Workbook
Dim ws As Worksheet, delWS As Worksheet
Dim i As Long, lastRow As Long, lastCol As Long
Dim shts() As Variant
Dim rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbOld = ActiveWorkbook
shts() = Array("Sheet 1", "Sheet 2", "Sheet 3")
Set wbNew = Workbooks.Add
Set delWS = ActiveSheet
wbOld.Worksheets(Array("Sheet 1", "Sheet 2", "Sheet 3")).Copy wbNew.Worksheets(1)
delWS.Delete
For i = LBound(shts) To UBound(shts)
With wbNew.Worksheets(shts(i))
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Value = rng.Value
End With
Next i
wbNew.SaveAs "L:\Performance Data\UK Sales\Sales (Latest).xlsx"
wbNew.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note: I am not sure which workbook you want to paste the values in. As it is above, it does this in the COPIED workbook, not original.
Related
I asked a question about this piece of code yesterday but this is part two. Once the identified sheets have detached from the original workbook, they maintain all of their formulas (xlPasteValuesAndNumberFormats). There are two sheets in particular, "REQUESTOR" and "Copy", that am only needing the values for but the other 3 sheets need to bring their formulas along during the detachment. The reason is because those 2 sheets contain external referencing formulas while the other 3 do not. How do I get all of the sheets to detach into a new work book and make the 2 identified sheets be values only while the other 3 carry all of their formulas into the new workbook?
Private Sub CommandButton1_Click()
' Plain_Copy Macro
Sheets("PROCUREMENT").Visible = True
Sheets("Request").Visible = True
Sheets("LISTS").Visible = True
Sheets("Copy").Visible = True
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim ws As Worksheet
With ActiveWorkbook
.Sheets(Array("REQUESTOR", "PROCUREMENT", "Request", "LISTS", "Copy")).Copy
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
With ws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
End With
TempWindow.Close
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
Avoid any potential problems with nesting With ActiveWorkbook for both the original and the copy by assigning them to variables and then it is clear which is being processed.
Option Explicit
Private Sub CommandButton1_Click()
' Plain_Copy Macro
Dim wb As Workbook, wbCopy As Workbook
Dim ws As Worksheet, ar, v
ar = Array("REQUESTOR", "PROCUREMENT", "Request", "LISTS", "Copy")
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
With wb
For Each v In ar
.Sheets(v).Visible = True
Next
.Sheets(ar).Copy
Set wbCopy = ActiveWorkbook
End With
For Each ws In wbCopy.Worksheets
If ws.name = "REQUESTOR" Or ws.name = "Copy" Then
With ws.UsedRange
' replace formula with values
.Value2 = .Value2
End With
End If
Next
Application.ScreenUpdating = True
MsgBox "Copy is " & wbCopy.name
End Sub
This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub
What I want to add is.. Macro should delete the old from "Master"sheet and refresh the sheet1,sheet2 and sheet3
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
Sheets("Master").Name = "Master"
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy Sheets("Master") _
.Range("A" & Rows.Count).End(xlUp).Offset(1)
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Call Formatting
Next Ws
End Sub
You mean this? Delete the data on Master before pasting it?
(Also stop changing the edits on your post)
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
'Refresh all sources/Tables
ThisWorkbook.RefreshAll
'Clear All but first Row
Sheets("Master").Rows("2:" & Rows.Count).ClearContents
'Loop sheets
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy
Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Call Formatting
Next Ws
End Sub
I found the code below on this site which works perfectly once I referenced the appropriate cells etc. However, I tried to modify it to keep formulas but I am not having much luck. Any help is greatly appreciated.
Sub test()
Dim names As New Collection
Dim ws As Worksheet, ws1 As Worksheet
Dim wb As Workbook
Dim lastrow As Long
Dim cell As Range
Dim nm As Variant
Dim res As Range
Dim rngHeader As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'change "A" to column with "Names"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'change "A" to column with "Names"
For Each cell In .Range("A2:A" & lastrow)
On Error Resume Next
'collect unique names
names.Add CStr(cell.Value), CStr(cell.Value)
On Error GoTo 0
Next cell
'disable all filters
.AutoFilterMode = False
'change "A1:C1" to headers address of your table
Set rngHeader = .Range("A1:C1")
For Each nm In names
With rngHeader
'Apply filter to "Name" column
.AutoFilter Field:=1, Criteria1:=nm
On Error Resume Next
'get all visible rows
Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'if there is visible rows, create new WB
If Not res Is Nothing Then
'create new workbook
Set wb = Workbooks.Add
'add sheet with name form column "Names" ("Paul", "Nick" or etc)
wb.Worksheets.Add.name = nm
'delete other sheets from new wb
For Each ws1 In wb.Worksheets
If ws1.name <> nm Then ws1.Delete
Next
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
End With
'save wb
wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
Set wb = Nothing
End If
End With
Next
'disable all filters
.AutoFilterMode = False
End With
Set names = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There is a part in your code which states that it copies / pastes data:
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
End With
If you copy the .Formula instead of the .Value then it should work. Give it a try and let us know.
I have Workbook, source.xlsm, Worksheet "test1" Column A6:A20 that I need to copy to another WorkBook located on my C:... named dest.xlsx, Worksheet "Assets", Column "I". I need to be able to copy the data and be able to add to the column without overwriting the previous data copied. Any help would be a life saver.
Sub Align()
Dim TargetSh As String
TargetSh = "Assets"
For Each WSheet In Application.Worksheets
If WSheet.Name <> TargetSh Then
WSheet.Select
Range("A6:A20").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets(TargetSh).Select
lastRow = Range("I65532").End(xlUp).Row
Cells(lastRow + 1, 1).Select
ActiveSheet.Paste
End If
Next WSheet
End Sub
Is this what you are trying? I have not tested it but I think it should work. Let me know if you get any errors.
Sub Sample_Copy()
Dim wb As Workbook, wbTemp As Workbook
Dim ws As Worksheet, wsTemp As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("test1")
'~~> Change path as applicable
Set wbTemp = Workbooks.Open("C:\dest.xlsx")
Set wsTemp = wbTemp.Sheets("Assets")
lastRow = wsTemp.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("A6:A20").Copy wsTemp.Range("I" & lastRow)
Application.CutCopyMode = False
'~~> Cleanup
wbTemp.Close savechanges:=True
Set wb = Nothing: Set wbTemp = Nothing
Set ws = Nothing: Set wsTemp = Nothing
End Sub
HTH
Sid