I have workbook and there many sheets i want to copy one by one sheets to new work book and rename workbook
I tried, but it saved in one workbook instead of separate workbooks also I don't want to copy first worksheet to copy new workbook
Option Explicit
Sub CreateWorkBooks()
Dim ws As Object
Dim i As Long
Dim ws_num As Integer
Application.ScreenUpdating = False
Set ws = Worksheets
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & Worksheets("DATA Sheet").Range("m2") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
End Sub
Welcome to SO. Only simple self explanatory corrections made. Try
Option Explicit
Sub CreateWorkBooks()
Dim ws As Worksheet ' Worksheets instead of Object
Dim i As Long
Dim ws_num As Integer
'Application.ScreenUpdating = False
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
Set ws = ThisWorkbook.Worksheets(i) 'set ws to each sheet in the workbook
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
' Thisworkbook is to be added to refer Worksheets("DATA Sheet").Range("m2").Value
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & ThisWorkbook.Worksheets("DATA Sheet").Range("m2").Value & ".xlsx"
ActiveWorkbook.Close False
Next
'Application.ScreenUpdating = True
End Sub
Related
I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub
I have a workbook with 3 sheets in them, I am using the below macro to export the sheets as .csv files. However sheet1 gets exported with the data in it and sheet2 gets exported without any data in it and is a blank file. The goal is to successfully export Sheet1 and Sheet2 as .csv files with data in them without overwriting the original workbook. Any help would be much appreciated.
Sub Export_Files_Click()
Dim ws As Worksheet
Dim path As String
path = ActiveWorkbook.path & "\" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
For Each ws In Worksheets
ws.Activate
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Next
End Sub
Export Worksheets (to Separate Workbooks)
Consider the active workbook named Test.xlsm containing only worksheets Sheet1 and Sheet2 (tab names).
Then the following, run from this or another workbook, will save the files Test_Sheet1.csv (containing only the worksheet Sheet1) and Test_Sheet2.csv (containing only the worksheet Sheet2) to the active workbook's path (folder).
Standard Module e.g. Module1
Option Explicit
Sub ExportWorksheets()
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim swbPathAndLeftName As String: swbPathAndLeftName _
= swb.path & "\" & Left(swb.Name, InStrRev(swb.Name, ".") - 1) & "_"
Application.ScreenUpdating = False
Dim sws As Worksheet
Dim dwb As Workbook
Dim dFilePath As String
For Each sws In swb.Worksheets
dFilePath = swbPathAndLeftName & sws.Name & ".csv"
sws.Copy ' copies worksheet to a new (one worksheet) workbook...
Set dwb = ActiveWorkbook ' ... which becomes active
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSV, _
CreateBackup:=False ', Local:=True ' if semicolon instead of comma
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation, "Export Worksheets"
End Sub
The CommandButton (wherever)
Sub Export_Files_Click()
ExportWorksheets
End Sub
i'm a beginner in VBA and i need to do the following. Starting from a workbook i should create another one without formulas and macro code.
I found some solutions and based on that i modeled my own code:
Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String
sPath = "C:\Users\"
sFileName = "OVERALL RECAP"
Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
wsCopy.Cells.copy
wsPaste.Cells.PasteSpecial xlPasteValues
wsPaste.Cells.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
wsPaste.Name = "Expenses" 'Change if needed
wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
I need to copy more than one sheet and tried to use the official documentation like:
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
But i didn't manage to implement this into the code above, any suggestion? Thanks.
Copy Worksheets to New Workbook
The Flow
Basically, the procedure will:
create a copy of ThisWorkbook (the workbook containing this code) in the destination folder,
open the copy and continue to work with it,
copy values to (remove formulas from) the specified worksheets,
delete the not specified sheets,
rename the specified worksheets,
save the copy to a new workbook in .xlsx format,
delete the copy.
Remarks
If a workbook with the same name (e.g. OVERALL RECAP) is already open, it will crash Excel.
Be careful when determining the worksheet names, because if you try to rename a worksheet using an already existing name, an error will occur.
The Code
Option Explicit
Sub copyWorksheets()
Const dPath As String = "C:\Users"
Const dFileName As String = "OVERALL RECAP"
Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
Const PasteList As String = "Expenses,Sheet2,Sheet4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
Dim nUpper As Long: nUpper = UBound(CopyNames)
Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
Application.ScreenUpdating = False
' Save a copy.
wb.SaveCopyAs tFilePath
' Work with the copy.
With Workbooks.Open(tFilePath)
' Copy values (remove formulas).
Dim n As Long
For n = 0 To nUpper
With .Worksheets(CopyNames(n)).UsedRange
.Value = .Value
End With
Next n
' Delete other sheets.
Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
If dCount > 0 Then
Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
Dim sh As Object ' There maybe e.g. charts.
n = 0
For Each sh In .Sheets
If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
n = n + 1
DeleteNames(n) = sh.Name
End If
Next sh
Application.DisplayAlerts = False
.Sheets(DeleteNames).Delete
Application.DisplayAlerts = True
End If
' Rename worksheets.
For n = 0 To nUpper
If CopyNames(n) <> PasteNames(n) Then
.Worksheets(CopyNames(n)).Name = PasteNames(n)
End If
Next n
' Save workbook.
.Worksheets(1).Activate
Application.DisplayAlerts = False
.SaveAs _
Filename:=dPath & "\" & dFileName, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'.Close SaveChanges:=False ' Close the new workbook.
End With
' Delete the copy.
Kill tFilePath
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation, "Success"
'wb.Close SaveChanges:=False ' Close ThisWorkbook.
End Sub
The code below takes the opposite approach to the earlier one. It copies the entire workbook to a new name and then modifies it. You can list the sheets you want to keep. Formulas in them will be converted to their values. Sheets not listed will be deleted.
Sub SaveValuesOnly()
' 154
' list the sheets you want to keep by their tab names
Const SheetsToKeep As String = "Sheet1,Sheet3"
Dim sFileName As String
Dim sPath As String
Dim Wb As Workbook ' the new workbook
Dim Ws As Worksheet ' looping object: worksheet
Dim Keep() As String ' array of SheetsToKeep
Dim i As Long ' loop counter: Keep index
sPath = Environ("UserProfile") & "\Desktop\"
sFileName = "OVERALL RECAP"
Keep = Split(SheetsToKeep, ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' create a copy of the ActiveWorkbook under a new name
ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
For Each Ws In Wb.Worksheets
' check if the sheet is to be kept
For i = UBound(Keep) To 0 Step -1
If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
Then Exit For
Next i
If i = True Then ' True = -1
Ws.Delete
Else
' keep the sheet
With Ws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
' you can repeat PasteSpecial here to copy more detail
End With
End If
Next Ws
' change the file format to xlsx (deleting copy of this code in it)
Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
Kill sPath & sFileName & ".xlsm"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
There are a few points you need to be aware of. One, the ActiveWorkbook will be copied. That is presumed to the ThisWorkbook (the one containing the code) but it could be any other. Two, any workbook by the targeted name already existing at the location specified by sPath will be over-written without warning. Three, alerts are turned off while the code runs. If it happens to crash they will remain turned off until you restart Excel or enter Application.DisplayAlerts = True [Enter] in the Immediate window.
Last, but not least, sheets are processed in sequence of their index numbers (left to right). If your formulas in the kept sheets refer to data in sheets that get deleted the sequence is important. You may have to run two loops instead of the one my code has. Use one loop to replace formulas and another just to delete.
My aim is to merge all workbooks having multiple sheets from any specified folder to one workbook of multiple sheets. (I have attached code below)
The problem is I don’t want external links to be maintained, I tried to break these links using Macro, it’s also working. (just using breaklink command, attached below)
But what I exactly want is, After merging all workbooks in one workbook, instead of external links I need links b/w these merged sheets, so is there any strategy that I can use?
Code for merge all workbooks into one workbook
Sub merge()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = "C:\Users\Samiya jabbar\Desktop\test\"
Filename = Dir(FolderPath)
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Break link
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
In order to move all formula references correctly:
Open all files that are involved before you start moving.
Move your sheets (don't copy them).
After all movements are done: Close the files you don't need anymore (don't save changes if you want to keep the original files as before moving sheets).
Save your merged workbook.
Here is a proof of concept:
First we create 3 files with 2 workbooks each
Public Sub CreateTestWorkbooks()
Const Path As String = "C:\Temp\MoveTest\"
Const nWb As Long = 3 'amount of workbooks to create
Const nWs As Long = 2 'amount of worksheets in each workbook
Dim NewWb() As Workbook
ReDim NewWb(1 To nWb) As Workbook
Dim iWs As Long
Application.ScreenUpdating = False
'create workbooks
Dim iWb As Long
For iWb = 1 To nWb
Set NewWb(iWb) = Application.Workbooks.Add
For iWs = 1 To nWs - 1
NewWb(iWb).Worksheets.Add After:=NewWb(iWb).Sheets(NewWb(iWb).Sheets.Count)
Next iWs
NewWb(iWb).SaveAs Filename:=Path & "File" & iWb & ".xlsx"
Next iWb
'write formulas
Dim iFormula As Long
For iWb = 1 To nWb
For iWs = 1 To nWs
NewWb(iWb).Worksheets(iWs).Range("A1").Value = "File" & iWb & ".xlsx " & "Sheet" & iWs
For iFormula = 1 To nWb
NewWb(iWb).Worksheets(iWs).Cells(iFormula, "B").Formula = "=[File" & iFormula & ".xlsx]Sheet" & iWs & "!$A$1"
Next iFormula
Next iWs
Next iWb
'save and close workbooks
For iWb = 1 To nWb
NewWb(iWb).Close SaveChanges:=True
Next iWb
Application.ScreenUpdating = True
MsgBox "All " & nWb & " files were created.", vbInformation
End Sub
Then we consolidate them
Public Sub ConsolidateWorkbooks()
Const Path As String = "C:\Temp\MoveTest\"
Dim OpenedWorkbooks As Collection
Set OpenedWorkbooks = New Collection
Application.ScreenUpdating = False
'loop through files and open them all
Dim File As String
File = Dir(Path & "*.xlsx")
Do While File <> vbNullString
OpenedWorkbooks.Add Application.Workbooks.Open(Filename:=Path & File, UpdateLinks:=True)
File = Dir()
Loop
'create a new workbook to consolidate all worksheets
Dim ConsolidateWb As Workbook
Set ConsolidateWb = Application.Workbooks.Add
'consolidate
Dim wb As Workbook
For Each wb In OpenedWorkbooks
Dim sh As Variant
For Each sh In wb.Sheets
sh.Move After:=ConsolidateWb.Sheets(ConsolidateWb.Sheets.Count)
'this changes the constant in A1 of each sheet to make it
'visible that formulas are now pointing to the new file (no formula changes are made here)
With ConsolidateWb.Sheets(ConsolidateWb.Sheets.Count)
.Range("A1").Value = "Consolidated.xlsx " & .Name
End With
Next sh
Next wb
Application.ScreenUpdating = True
ConsolidateWb.SaveAs Filename:=Path & "Consolidated.xlsx"
End Sub
I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....
my code so far:
Sub Newyeartest()
sheetstocopy = "data"
Worksheets(sheetstocopy).Copy
Dim FName As String
Dim FPath As String
FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub
If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?
Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.
The code saves the workbook first, using the path of the current workbook;
Then it starts checking every worksheet, making sure that the name is not "data";
If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;
Sub NewTest()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"
Dim sheetToCopy As String: sheetToCopy = "data"
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> sheetToCopy Then
If ThisWorkbook.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wks.Name).Delete
Application.DisplayAlerts = True
Else
MsgBox "Last worksheet cannot be deleted!"
End If
End If
Next wks
End Sub
This should do the trick:
Option Explicit
Sub Newyeartest()
Dim wb As Workbook
Dim SheetNames As Variant, Key As Variant
Dim FName As String, FPath As String
Application.ScreenUpdating = False
SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy
Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook
'loop through the sheets you previously stored to copy them
For Each Key In SheetNames
ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
Next Key
'delete the first sheet on the new created workbook
Application.DisplayAlerts = False
wb.Sheets(1).Delete
FPath = "C:\Test"
FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You cannot save directly to C:\ so you need to create a folder and the code will work.