I have a workbook with many sheets, both hidden and visible.
I need to copy all but the first sheet to individual folders that are not created
In the original workbook I have :master sheet, sheet 1, sheet 2, sheet 3, etc
every sheet has a title inside the sheet at cell A1
I want to copy all EXCEPT master sheet and the hidden sheets.
I need to save the sheets to individual workbooks
U:\folder
\sheet 1
\sheet 2
\sheet 3
I am so confused. I know i need a loop to go through the sheets, I need a loop to save and set the name variable from the sheet as it runs through the loop, and then it also has to create the folders if needed.
I am so lost in how to mesh that many loops and commands. I can see the overall outline but I am getting lost.
I would really appreciate the help.
I've tried several individual solutions but I have NO idea how to incorporate all of them.
'some of the code i found online I've been trying to merge together to one
'copy only visible sheets
Sub saveVisibleSheetsAsXLSM() 'saves all visible sheets as new xlsx files
Const exportPath = "x:\yourDestinationPath\"
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets 'for each worksheet
If ws.Visible Then 'if it's visible:
Debug.Print "Exporting: " & ws.Name
ws.Copy '(if no params specified, COPY creates + activates a new wb)
Set wbNew = Application.ActiveWorkbook 'get new wb object
wbNew.SaveAs exportPath & ws.Name & ".xlsm", 52 'save new wb
wbNew.Close 'close new wb
Set wbNew = Nothing 'cleanup
End If
Next ws
Set ws = Nothing 'clean up
End Sub
'skip first sheet code
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
MsgBox ActiveWorkbook.Worksheets(I).Name
Next I
End Sub
Everything was right with your code except the Folder Paths.
Use MkDir to create a Folder and then save the Files in it. Use AND in If condition to skip the Master Sheet. I have amended the code.
Code:
Sub saveVisibleSheetsAsXLSM()
Const exportPath = "x:\yourDestinationPath\" '**Change your Path HERE**
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets
If ws.Visible And Not ws.Name = "master sheet" Then '**Check the spelling of Master Sheet**
Debug.Print "Exporting: " & ws.Name
ws.Copy
Set wbNew = Application.ActiveWorkbook
MkDir exportPath & ws.Name
wbNew.SaveAs exportPath & ws.Name & "\" & ws.Name & ".xlsm", 52
wbNew.Close
Set wbNew = Nothing
End If
Next ws
End Sub
Related
I am trying to copy data from a master file and then paste it into workbooks already open on a loop.
It gets stuck at
If WS.Name = WB.Sheets("FX Rates") Then
Sub Update_Files()
Dim WB As Workbook
Dim WS As Worksheet
Dim Master As Workbook
Set Master = ThisWorkbook
ThisWorkbook.Sheets("FX").Range("A1:I148").Select
Selection.Copy
For Each WB In Application.Workbooks
If WB.Name <> "Master File.xlsb" Then
If WS.Name = WB.Sheets("FX Rates") Then
'Paste FX data from Master
Range("A1").PasteSpecial xlpastevalues
End If
End If
Next WB
As commented, looks like you're missing a loop for your worksheets. Currently, you're only looping through your workbooks, not worksheets.
Added a loop to address this. Code loops through each open workbook, checks name. If Name <> "Master File.xlsb", then it continues to the next loop.
This second loop iterates over each worksheet in current workbook, and checks if it's name equals "FX Rates", if it does, it pastes copied selection and continues the loop.
There are however much more VBA-ish way to achieve the same thing, but this answers your question. It compiles and runs just fine.
Sub Update_Files()
Dim WB As Workbook
Dim WS As Worksheet
Dim Master As Workbook
Set Master = ThisWorkbook
ThisWorkbook.Sheets("FX").Range("A1:I148").Select
Selection.Copy
For Each WB In Application.Workbooks
If WB.Name <> "Master File.xlsb" Then
For Each WS In WB.Worksheets
If WS.Name = "FX Rates" Then
'Paste FX data from Master
WS.Range("A1").PasteSpecial xlPasteValues
End If
Next WS
End If
Next WB
End Sub
I try to merge data from different excel workbooks with the same worksheet names in them, into 1 separate excel workbook. My code merges all worksheets in those workbooks. For example: that 1 separate excel looks like that in the end: a,b,c,a(2),b(2),c(2),a(3),b(3),c(3)
I need to enter the criteria that it merges all worksheets with name "a" from different workbooks into a single worksheet "a" in the separate excel file.
here is my code:
Sub CombineWorkbooks()
Dim Path As String
Path = "C:\Users\Desktop\Products_test\"
Dim FileName As String
FileName = Dir(Path & "*.xlsm")
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Worksheets(1).Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
This code will loop through all the workbooks in the specified folder.
It will copy each worksheet from the workbooks to the workbook the code is in, i.e. ThisWorkbook.
It checks to see if a worksheet with same name as that being copied exists in the destination workbook.
If a worksheet with the same name is found then the data from the source worksheet is copied below the existing data.
If a worksheet with the same name is not found the entire worksheet is copied to the destination workbook.
Option Explicit
Sub CombineWorkbooks()
Dim wbSrc As Workbook
Dim wsDst As Worksheet
Dim wsSrc As Worksheet
Dim rngSrc As Range
Dim Path As String
Dim FileName As String
Path = "C:\Users\vladimir\Desktop\Products_test\"
FileName = Dir(Path & "*.xlsm")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Set wbSrc = Workbooks.Open(Path & FileName)
For Each wsSrc In wbSrc.Sheets
Set wsDst = FindWS(wsSrc.Name, ThisWorkbook)
If wsDst Is Nothing Then
wsSrc.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Else
With wsSrc.Range("A1").CurrentRegion
Set rngSrc = .Offset(1).Resize(.Rows.Count - 1)
End With
rngSrc.Copy wsDst.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next wsSrc
wbSrc.Close
FileName = Dir()
Loop
Worksheets(1).Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function FindWS(strWSName As String, wb As Workbook) As Worksheet
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name = strWSName Then
Exit For
End If
Next ws
If Not ws Is Nothing Then
Set FindWS = ws
End If
End Function
In your comment you mention two possible solutions. Here's the simpler solution, which is having an end result of a, a(2), a(3)
To do that, replace the three lines of the For...Next loop with this:
For Each ws In ActiveWorkbook.Sheets
If ws.Name = "a" Then
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next ws
That will only copy across the worksheets that are called a, so all of the b and c sheets will be ignored.
The other solution is also possible. When I have a bit more time available I'll write that up (or anyone else can).
I need to create a button press that will automatically export each tab in the workbook to an individual Excel workbook.
This is the code I'm currently using; what do I need to change?
Sub ExportToXLSX()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
nm = ws.Name
ws.SaveAs ("C:\Users\username\Desktop\Box 2 Files\" & nm & ".xlsx")
Next ws
End Sub
Edit: I also need these individual tabs to save to the specified file destination in addition to exporting into individual workbooks.
Here's an approach using Worksheet.Copy to create a new workbook.
Sub ExportToXLSX()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\username\Desktop\Box 2 Files\" & ws.Name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
Next
End Sub
Sub SaveShtsAsBook()
‘Select all visible and hide sheet’
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xlsx"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I have a workbook, that contains many sheets which have visible and hide ones. I only want to export each visible sheet to individual workbook. this current code above can do the export for all the sheet in the workbook but I have to delete them 1 by 1 after that. Hope that explains my situation.
All you need to add to your code to exclude hidden sheets is a simple If..Then statement to check whether the Worksheet.Visible property is True or False.
If Not yourWorsheet.Visible Then... ... then you skip that worksheet.
The following procedure is a simpler overall approach to what you're trying to accomplish...
Export Visible worksheets to their own workbooks:
The worksheet.Copy method will create a new workbook if neither Before nor After are specified.
Sub saveVisibleSheetsAsXLSM() 'saves all visible sheets as new xlsx files
Const exportPath = "x:\yourDestinationPath\"
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets 'for each worksheet
If ws.Visible Then 'if it's visible:
Debug.Print "Exporting: " & ws.Name
ws.Copy '(if no params specified, COPY creates + activates a new wb)
Set wbNew = Application.ActiveWorkbook 'get new wb object
wbNew.SaveAs exportPath & ws.Name & ".xlsm", 52 'save new wb
wbNew.Close 'close new wb
Set wbNew = Nothing 'cleanup
End If
Next ws
Set ws = Nothing 'clean up
End Sub
Worksheet.Copy Remarks:
If you don't specify either Before or After, Microsoft Excel creates a new workbook that contains the copied sheet object that contains the copied Worksheet object. The newly created workbook holds the Application.ActiveWorkbook Property (Excel) property and contains a single worksheet. The single worksheet retains the Worksheet.Name Property (Excel) and Worksheet.CodeName Property (Excel) properties of the source worksheet. If the copied worksheet held a worksheet code sheet in a VBA project, that is also carried into the new workbook.
An array selection of multiple worksheets can be copied to a new blank Workbook Object (Excel) object in a similar manner.
(Source: Documentation)
Background
First of all I realise all of this is a perfect task for a database but I don't currently have that option available and I think it's a good learning experience to continue doing this in excel.
I have multiple workbooks each containing a list of identifying numbers, through the code below I enter the name of the workbook I require and the list is imported to main my workbook containing multiple columns of data. I then ran my Match and Export sub to break up the main data set into different sheets.
Question
Is there a way to use a for loop for each of the files in the containing folder so that I don't have to identify each workbook in turn?
Sub Export_Specified_Contractor()
Dim listwb As Workbook, mainwb As Workbook
Dim fname As String
Dim sht As Worksheet, oput As Worksheet
Dim LRow As Long, oLRow As Long
Dim cprng As Range, orng As Range
'--> Get the name of the contractor list to be exported
fname = Application.InputBox("Enter Contractor Name", "Name?")
Set mainwb = ThisWorkbook
With Application
'--> Set contractor list file
Set listwb = .Workbooks.Open _
("C:\Documents and Settings\alistairw\My Documents\Disallowed Items\Contractor Lists\" & fname)
End With
Set sht = listwb.Sheets("Sheet1")
'--> Copy contractor list
With sht
LRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:A" & LRow).Copy
End With
mainwb.Activate
'--> Create contractor list sheet in main workbook and paste values
With mainwb
On Error Resume Next
Sheets("Sheet2").Delete
Sheets.Add.Name = "Sheet2"
Set oput = Sheets("Sheet2")
With oput
.Range("A1").PasteSpecial
End With
End With
Call Match_and_Export
'--> Delete the list workbook and list sheet
Application.DisplayAlerts = False
listwb.Close
oput.Delete
Application.DisplayAlerts = True
End Sub
looping through a folder:
MyPath = "C:\Documents and Settings\alistairw\My Documents\Disallowed Items\Contractor Lists\"
strFilename = Dir(MyPath & "\*.xlsx", vbNormal) 'change to xls if needed
If Len(strFilename) = 0 Then Exit Sub ' exit if no files in folder
Do Until strFilename = ""
'Your code here
strFilename = Dir()
Loop