I have a Macro code that copy's all sheets in my workbook to a new workbook. This works well but the problem is that it copies hidden sheets as well. Can someone help me modify the code so that it copies only the visible sheets.
Sub export()
Dim Sht As Worksheet
Dim DestSht As Worksheet
Dim DesktopPath As String
Dim NewWbName As String
Dim wb As Workbook
Dim i As Long
Set wb = Workbooks.Add
DesktopPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\"
NewWbName = "report " & Format(Now, "yyyy_mm_dd _hh_mm_ss") & ".xlsx"
i = 1
For Each Sht In ThisWorkbook.Sheets
If i <= wb.Sheets.Count Then
Set DestSht = wb.Sheets(i)
Else
Set DestSht = wb.Sheets.Add
End If
Sht.Cells.Copy
With DestSht
.Cells.PasteSpecial (xlPasteValues)
.Cells.PasteSpecial (xlPasteFormats)
.Name = Sht.Name
End With
i = i + 1
Next Sht
Application.DisplayAlerts = False
wb.SaveAs Filename:=DesktopPath & NewWbName, FileFormat:=51
wb.Close
MsgBox "You Can Find The Exported File In Your Desktop.", vbOKOnly + vbInformation, "Export Sucessful!"
Application.DisplayAlerts = True
End Sub
Sub export()
Dim Sht As Worksheet
Dim DestSht As Worksheet
Dim DesktopPath As String
Dim NewWbName As String
Dim wb As Workbook
Dim i As Long
Set wb = Workbooks.Add
DesktopPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\"
NewWbName = "report " & Format(Now, "yyyy_mm_dd _hh_mm_ss") & ".xlsx"
i = 1
For Each Sht In ThisWorkbook.Sheets
If Sht.Visible = xlSheetVisible Then
If i <= wb.Sheets.Count Then
Set DestSht = wb.Sheets(i)
Else
Set DestSht = wb.Sheets.Add
DestSht.Move After:=Sheets(wb.Sheets.Count)
End If
Sht.Cells.Copy
With DestSht
.Cells.PasteSpecial (xlPasteValues)
.Cells.PasteSpecial (xlPasteFormats)
.Name = Sht.Name
End With
i = i + 1
End If
Next Sht
Application.DisplayAlerts = False
wb.SaveAs Filename:=DesktopPath & NewWbName, FileFormat:=51
wb.Close
MsgBox "You Can Find The Exported File In Your Desktop.", vbOKOnly + vbInformation, "Export Sucessful!"
Application.DisplayAlerts = True
End Sub
Related
Hi I have main excel file with 10 sheets (sheet1...sheet10), and i need help with extracting (create new folder with sheet name) sheet5 and sheet6 in folder which link is in sheet1 n6 cell, and sheet7 and sheet8 in folder which link is in sheet1 n7 cell.sheets must be extracted without macros and formulas, only paste as values. For now i only have this which is creating workbooks in main file folder, i dont know how to setup extracting in diferent folders.
Private Sub CommandButton2_Click()
Dim xWs As Worksheet
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Done.")
End Sub
Export Single Worksheets to Workbooks
Option Explicit
Private Sub CommandButton2_Click()
Const lName As String = "Sheet1"
' The following two lines are dependent on each other.
Dim dExtension As String: dExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim lCellAddresses As Variant: lCellAddresses = Array("N6", "N7")
Dim dNames As Variant: dNames = Array( _
Array("Sheet5", "Sheet6"), _
Array("Sheet7", "Sheet8"))
Dim swb As Workbook: Set swb = ThisWorkbook
Dim lws As Worksheet: Set lws = swb.Worksheets(lName)
Application.ScreenUpdating = False
Dim dwb As Workbook
Dim sws As Worksheet
Dim dFilePath As String
Dim n As Long
For Each sws In swb.Worksheets
For n = LBound(dNames) To UBound(dNames)
If IsNumeric(Application.Match(sws.Name, dNames(n), 0)) Then
sws.Copy
Set dwb = ActiveWorkbook
With dwb.Worksheets(1).UsedRange
.Value = .Value
End With
dFilePath = CStr(lws.Range(lCellAddresses(n)).Value)
If Right(dFilePath, 1) <> "\" Then dFilePath = dFilePath & "\"
If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
dFilePath = dFilePath & sws.Name & dExtension
Application.DisplayAlerts = False ' overwrite: no confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=dFileFormat
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Exit For
End If
Next n
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
Hi I have the following code which loops through dropdown selections and saves each result as a new workbook based on the named range in cell G3. I am trying to edit the code so that it saves all the worksheets to the new file instead of just the active one, if anyone could help? thank you
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb As Workbook
Dim nws As Worksheet
Dim rng As Range
Dim Path As String
Dim myDate As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
Path = "C:\Users\bradley\Desktop\Sales by Month\"
myDate = Format(Now(), "MM-DD-YYYY")
For i = 1 To 4
rng = ws.Range("J" & i)
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Summary")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteValues)
End With
Application.DisplayAlerts = False
nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx",
FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
End Sub
Loop through the sheets but only create a workbook on the first one.
Option Explicit
Sub myFiles()
Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
Dim wb As Workbook, nwb As Workbook
Dim ws As Worksheet, rng As Range
Dim myDate As String, i As Long, j As Long
Dim filename As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
myDate = Format(Now(), "MM-DD-YYYY")
Application.ScreenUpdating = False
For i = 1 To 4
rng.Value2 = ws.Range("J" & i).Value2
' copy all sheets
For j = 1 To wb.Sheets.Count
If j = 1 Then
wb.Sheets(j).Copy
Set nwb = ActiveWorkbook
Else
wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
End If
With nwb.Sheets(j)
.UsedRange.Value2 = .UsedRange.Value2
End With
Next
' save workbook
filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
Application.DisplayAlerts = False
nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I have a template file and 4 source documents that I use to fill the template. For each row in sheet2, I create a new blank template and fill it out, resulting in somewhere between 10-100 files. I want to save these in a loop, but having issues with Excel force closing on me. This is my code so far, recycled from a different project.
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
Dim folderName As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
folderName = Format(Date, "ddmmyyyy")
'set path to save
'fp = "<PATH HERE>" & folderName
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\ThisProject\csvOutput\" & folderName
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder (fp)
End If
'cycle through each of the worksheets
For w = 6 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add after:=Sheets(Sheets.Count)
Range("A1").Select
ActiveSheet.Paste
Worksheets(1).Delete
Worksheets(1).Name = fn
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub ```
The code below worked for me: not sure exactly where the problem might vbe with your posted code, but within your With blocks not everything is scope to the block using a leading .
Sub Test()
Dim w As Long, wb As Workbook, wbNew As Workbook
Dim fp As String, fn As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
Set wb = ThisWorkbook
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\" & _
"ThisProject\csvOutput\" & Format(Date, "ddmmyyyy") & "\"
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder fp
End If
'cycle through each of the worksheets
For w = 6 To wb.Worksheets.Count
'explicitly create a new single-sheet workbook as the destination
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet)
wb.Worksheets(w).Copy before:=wbNew.Sheets(1)
DeleteSheet wbNew.Sheets(2)
With wbNew
fn = .Worksheets(1).Name
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
.Worksheets(1).Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Worksheets(2).Range("A1")
DeleteSheet .Worksheets(1)
.Worksheets(1).Name = fn
.SaveAs Filename:=fp & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
Next w
Exit Sub
bm_Safe_Exit:
MsgBox Err.Description
End Sub
'utility sub
Sub DeleteSheet(ws As Worksheet)
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
I have a Userform with a Listbox and a Export button. The Listbox will list all the Sheet names in the workbook. I want to be able to select the sheet names in the list box and click on export to make a copy in the desktop that creates a paste only value & formatting (without the formula and form buttons on the original sheet).
So for I was successful in listing the sheet name in the listbox, but I am having some trouble with the export button code, I get out of range error.
Private Sub CommandButton1_Click()
Dim lSht As Long
Dim wb As Workbook
Dim sPath As String
Dim sSheet As String
Dim NewWbName As String
Dim i As Long
'Set variables
Set wb = Workbooks.Add
'Add a filepath to your computer below
sPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\"
NewWbName = "Reports " & Format(Now, "yyyy_mm_dd _hh_mm")
i = 1
'Loop through listbox
For lSht = 0 To Me.sheetlist.ListCount - 1
'check if items selected
If Me.sheetlist.Selected(lSht) = True Then
'copy out the sheet and saveas
sSheet = Me.sheetlist.List(lSht)
With wb.Worksheets(sSheet).Copy
.PasteSpecial (xlPasteValues)
.PasteSpecial (xlPasteFormats)
End With
Application.DisplayAlerts = False
wb.SaveAs Filename:=DesktopPath & NewWbName, FileFormat:=xlNormal
wb.Close
MsgBox "You can find the export file in your desktop.", vbOKOnly + vbInformation, "Back Up Sucessful!"
Application.DisplayAlerts = True
End If
Next lSht
End Sub
Following or comments above, try the code below:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim newWb As Workbook
Dim sPath As String
Dim sSheet As String
Dim NewWbName As String
Dim lSht As Long
Dim NewSht As Worksheet
Dim i As Long
Dim firstExport As Boolean
'Set variables
Set wb = ThisWorkbook
Set newWb = Workbooks.Add
Application.DisplayAlerts = False
firstExport = True
'Add a filepath to your computer below
sPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\"
NewWbName = "Reports " & Format(Now, "yyyy_mm_dd _hh_mm")
'Loop through listbox
For lSht = 0 To Me.sheetlist.ListCount - 1
'check if items selected
If Me.sheetlist.Selected(lSht) = True Then
'copy out the sheet and saveas
sSheet = Me.sheetlist.List(lSht)
If firstExport Then
firstExport = False
' remove all sheets (exceot 1) in first Copy>Paste
For i = newWb.Sheets.Count - 1 To 1 Step -1
newWb.Sheets(i).Delete
Next i
' add new sheet to new workbook and put it at theend
Set NewSht = newWb.Sheets(newWb.Sheets.Count)
Else
' add new sheet to new workbook and put it at the end
Set NewSht = newWb.Sheets.Add(After:=newWb.Sheets(newWb.Sheets.Count))
End If
NewSht.Name = sSheet
With wb.Sheets(sSheet)
.Cells.Copy
NewSht.Cells.PasteSpecial (xlPasteValues)
NewSht.Cells.PasteSpecial (xlPasteFormats)
End With
End If
Next lSht
' need to move the save workbook outside the Copy all selected sheets "loop"
newWb.SaveAs Filename:=sPath & NewWbName, FileFormat:=xlNormal
newWb.Close True
MsgBox "You can find the export file in your desktop.", vbOKOnly + vbInformation, "Back Up Sucessful!"
Application.DisplayAlerts = True
End Sub
Is there a way to generate the ws In Worksheets(Array("DiscardedDataFile", "GephiNodeFile", "GephiEdgeFile")) for the 2nd Sub dynamically?
Edit: Updated with simoco code and my revision
Sub SaveSheetsAsNewBooks3()
Dim SheetName As String
Dim MyFilePath As String
Dim fileName As String
Dim ws As Worksheet, wsN As Worksheet
Dim wb As Workbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each ws In Worksheets
If ws.Index <> 1 Then
SheetName = ws.Name
ws.Copy
MyFilePath = ThisWorkbook.Path & "\" & SheetName
If Len(Dir(MyFilePath, vbDirectory)) = 0 Then
MkDir MyFilePath
End If
With ActiveWorkbook
'~save book in this folder
ActiveWorkbook.SaveAs fileName:=MyFilePath & "\" & SheetName & "_" & Format(Now(), "DD-MM-YY hh.mm") & ".csv", FileFormat:=6
ActiveWorkbook.Close SaveChanges:=True
End With
End If
Next ws
Sheets("Source").Select
End Sub
If I understood you correctly, you need something like this:
Sub SaveSheetsAsNewBooks2()
Dim SheetName As String
Dim MyFilePath As String
Dim fileName As String
Dim ws As Worksheet, wsN As Worksheet
Dim wb As Workbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
With ThisWorkbook
For Each ws In .Worksheets
If ws.Index <> 1 Then
SheetName = ws.Name
MyFilePath = ThisWorkbook.Path & "\" & SheetName
If Len(Dir(MyFilePath, vbDirectory)) = 0 Then
MkDir MyFilePath
End If
'create new workbook
ws.Copy
With ActiveWorkbook
'save new workbook in this folder
.SaveAs fileName:=MyFilePath & "\" & SheetName & "_" & Format(Now(), "DD-MM-YY hh.mm") & ".csv", FileFormat:=6
.Close SaveChanges:=True
End With
End If
Next ws
.Worksheets(1).Select
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub