I am using this code which exports activesheet to CSV. However, I am looking to modify this so I can pass as arguments the names of multiple sheets to export.
Sometimes it could be 2 sheets, sometimes it could be 10 sheets and I want to somehow define the names of the sheets as parameters for the export.
Sub saveSheetToCSV()
Dim myCSVFileName As String
Dim tempWB As Workbook
Application.DisplayAlerts = False
On Error GoTo err
myCSVFileName = ThisWorkbook.Path & "\" & "CSV-Exported-File-" & VBA.Format(VBA.Now, "dd-MMM-yyyy hh-mm") & ".csv"
ThisWorkbook.Sheets("YourSheetToCopy").Activate
ActiveSheet.Copy
Set tempWB = ActiveWorkbook
With tempWB
.SaveAs Filename:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
err:
Application.DisplayAlerts = True
End Sub
Export Worksheet to New Workbook
!!! denotes places to be checked carefully and possibly modified.
Option Explicit
Sub ExportWorksheetsTEST()
Dim wb As Workbook: Set wb = Workbooks.Open("C:\Test\Test.xlsx")
ExportWorksheets "Sheet1", "Sheet5", "Sheet8"
End Sub
Sub ExportWorksheets(ParamArray WorkSheetNames() As Variant)
Dim dFolderPath As String: dFolderPath = ThisWorkbook.Path & "\"
Const dFileExtension As String = ".csv"
Const dDateFormat As String = "dd-MMM-yyyy hh-mm"
Const dFileNameDelimiter As String = "-"
' This is the requirement.
' The recommendation is to put it as the first parameter of the procedure:
' Sub ExportWorksheets(ByVal wb As Workbook, ParamArray...)!!!
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim dDateString As String: dDateString = VBA.Format(VBA.Now, dDateFormat)
Dim ws As Worksheet
Dim n As Long
Dim dFilePath As String
For n = LBound(WorkSheetNames) To UBound(WorkSheetNames)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set ws = wb.Worksheets(WorkSheetNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
' Build the file path!!!
dFilePath = dFolderPath & ws.Name & dFileNameDelimiter _
& dDateString & dFileExtension
ws.Copy ' copy to a new workbook
With Workbooks(Workbooks.Count)
Application.DisplayAlerts = False ' overwrite w/o confirmation
.SaveAs Filename:=dFilePath, FileFormat:=xlCSV
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
Set ws = Nothing
End If
Next n
MsgBox "Worksheets exported.", vbInformation
End Sub
Related
I have a workbook with filtered ranges on each sheet. I have tried a couple different methods but when stepping through it only does the first sheet or none at all. This is what I have tried.
dim ws as worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.AutoFilterMode Then
Ws.AutoFilter.ShowAllData
End If
Next Ws
this one isn't doing anything at all
this one is less sophisticated and not what I want.
For Each ws In ThisWorkbook.Worksheets
Rows("1:1").Select
Selection.AutoFilter
Next ws
this is only doing the first worksheet and not moving to the next.
this is the full code and it is not returning any errors
Sub Cleanup()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Application.ScreenUpdating = False
FolderPath = "<folder path>"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Sheets(1).Delete
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
ws.AutoFilter.ShowAllData
End If
Next ws
End Sub
Copy Sheets to New Workbook
Issues
ThisWorkbook is the workbook containing this code. It has nothing to do with the code so far: you're adding a new (destination) workbook (mergedWb) and you're opening (source) files ('wb') whose sheets (Sheet) will be copied. Instead, you should use:
For Each ws In mergedWb.Worksheets
When you use the Sheets collection, you need to keep in mind that it also includes charts. Therefore, you should declare:
Dim Sheet As Object
You need to qualify the first destination (work)sheet to ensure the correct worksheet is deleted:
Application.DisplayAlerts = False ' delete without confirmation
mergedWb.Sheets(1).Delete
Application.DisplayAlerts = True
To turn off the auto filter, you need to use:
dws.AutoFilterMode = False
You can avoid the loop by copying all sheets (that are not very hidden) at once (per workbook):
swb.Sheets.Copy After...
The line swb.Sheets.Copy (no arguments) copies all sheets (that are not very hidden) to a new workbook.
The Code
Option Explicit
Sub Cleanup()
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
If Not CreateObject("Scripting.FileSystemObject") _
.FolderExists(SOURCE_FOLDER_PATH) Then
MsgBox "The folder '" & SOURCE_FOLDER_PATH & "' doesn't exist.", _
vbCritical
Exit Sub
End If
Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
If Len(sFileName) = 0 Then
MsgBox "No files found."
Exit Sub
End If
Dim swb As Workbook
Dim dwb As Workbook
Dim sFilePath As String
Dim IsNotFirstSourceWorkbook As Boolean
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
If IsNotFirstSourceWorkbook Then
swb.Sheets.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Else
swb.Sheets.Copy ' creates a new workbook containing the sheets
Set dwb = Workbooks(Workbooks.Count)
IsNotFirstSourceWorkbook = True
End If
swb.Close SaveChanges:=False
sFileName = Dir()
Loop
Dim dws As Worksheet
For Each dws In dwb.Worksheets
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Next dws
' Decide what to do with the new workbook e.g.:
' Application.DisplayAlerts = False ' overwrite without confirmation
' dwb.SaveAs sFolderPath & "CleanUp " & Format(Date, "yyyymmdd")
' Application.DisplayAlerts = True
' dwb.Close SaveChanges:=False ' it has just been saved
Application.ScreenUpdating = True
MsgBox "Cleaned up.", vbInformation
End Sub
i have an issue with this code. I need to save the data from a workbook to a new workbook but the new workbook doesn't save, I do it manually. I need it to save automatically. Any idea what is going on?
this is my code so far
Private Sub CommandButton3_Click()
Dim wb As Workbook
Dim wb_New As Workbook
Set wb = ThisWorkbook
Dim wbstring As String
Dim input_file_name As String
input_file_name = InputBox("Enter file name", "Enter new workbook file name")
wbstring = "C:\PIME\\"
Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
End Sub
You got it almost right - Set wb_New to the new workbook, populate the data then use SaveAs method.
Set wb_New = Workbooks.Add
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
wb_New.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Copy a Range to a New One-Worksheet Workbook
The only mistake I could find was that you need to remove one of the two trailing backslashes from the path:
wbstring = "C:\PIME\"
An Improvement
Option Explicit
Private Sub CommandButton3_Click()
' Source
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("NUMB")
' Destination
Dim dFolderPath As String: dFolderPath = "C:\PIME\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
Dim dExtension As String: dExtension = ".xls"
If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then
MsgBox "The path '" & dFolderPath & "' doesn't exist.", vbCritical
Exit Sub
End If
Dim dFileName As String
dFileName = InputBox("Enter file name", "Enter new workbook file name")
If Len(dFileName) = 0 Then
MsgBox "Canceled or no entry."
Exit Sub
End If
Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet) ' single...
Dim dws As Worksheet: Set dws = dwb.Worksheets(1) ' ... worksheet,...
' ... in another language it may not be 'Sheet1'.
' Copy by Assignement (the most efficient way to copy only values)
dws.Range("A1:I2000").Value = sws.Range("A1:I2000").Value
' Save(As)
Dim dFilePath As String: dFilePath = dFolderPath & dFileName & dExtension
Dim ErrNum As Long
Application.DisplayAlerts = False ' overwrite without confirmation
On Error Resume Next
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlExcel8 ' or 56
ErrNum = Err.Number
On Error GoTo 0
Application.DisplayAlerts = True
' Close
dwb.Close SaveChanges:=False
' Inform
If ErrNum = 0 Then
MsgBox "File saved.", vbInformation
Else
MsgBox "Could not save the file.", vbCritical
End If
End Sub
You may tweak your code as below...
Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
'Then either use wbNew.Save or wbNew.Close True as per your need
wbNew.Save 'To save the work and leave the new workbook open
'OR
wbNew.Close True 'To save the work and close the new workbook.
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
Dim mySheets As Variant
Dim sh As Worksheet
Dim I As Long
Dim FileName As String
Dim strdate As Variant
Dim strSName As Variant
strSName = ActiveSheet.name
strdate = Format(Now, "dd-mm-yy")
mySheets = Array("1.output", "2.output", "3.output", "4.output")
For I = 0 To UBound(mySheets)
Set sh = ThisWorkbook.Sheets(mySheets(I))
sh.Select
FileName = Application.GetSaveAsFilename(InitialFileName:=strsname & strdate, FileFilter:="Excel Files (*.csv), *.csv")
If FileName = "False" Then
MsgBox "Filename required", vbExclamation
Else
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
Next
End Sub
this code has issue which turned out the dialog box doesnt show the sheet name. any advice? i think the strsname has isssue.
Backup Worksheets to CSV
Application.GetSaveAsFilename requires the file extension (& ".csv").
Here's how I would have written it:
Option Explicit
Sub backupWorksheetsToCSV()
Const wsNamesList As String = "1.output,2.output,3.output,4.output"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
Dim DatePattern As String: DatePattern = Format(Date, "dd-mm-yy")
Dim ws As Worksheet
Dim n As Long
Dim iName As String
Dim fName As String
For n = 0 To UBound(wsNames)
Set ws = wb.Worksheets(wsNames(n))
iName = wb.Path & "\" & wsNames(n) & DatePattern & ".csv"
fName = Application.GetSaveAsFilename( _
FileFilter:="Excel Files (*.csv), *.csv", _
InitialFileName:=iName)
If fName = "False" Then
MsgBox "Filename required", vbExclamation
Else
ws.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
Next
End Sub
Fetch Sheet1 Data From Multiple Workbook Into Single Workbook Using VBA Or Macros
Option Explicit
Sub MergeExcels()
Dim Path As String, FName As String
Dim wb As Workbook
Dim ws As Worksheet
Path = ""
FName = Dir(Path & "*.xlsx")
With ThisWorkbook
Do While FName <> ""
Set wb = Workbooks.Open(Path & FName, ReadOnly:=True)
For Each ws In wb.Worksheets
ws.Copy After:=.Sheets(.Sheets.Count)
Next ws
wb.Close SaveChanges:=False
FName = Dir()
Loop
End With
End Sub
Above Code Fetch All Sheets In a Workbook But I Need Sheet1 Data Only
Change:
For Each ws In wb.Worksheets
ws.Copy After:=.Sheets(.Sheets.Count)
Next ws
To:
wb.Worksheets("Sheet1").Copy After:=.Sheets(.Sheets.Count)
Or, if you meant the first worksheet instead of the one named Sheet1:
wb.Worksheets(1).Copy After:=.Sheets(.Sheets.Count)
Option Explicit
Sub MergeExcels()
Dim Path As String, FName As String
Dim wb As Workbook
Dim ws As Worksheet
Path = "D:\BILL'S\Thankam\2019\June\Bills"
FName = Dir(Path & "*.xlsx")
With ThisWorkbook
Do While FName <> ""
Set wb = Workbooks.Open(Path & FName, ReadOnly:=True)
wb.Worksheets("Sheet1").Copy After:=.Sheets(.Sheets.Count)
wb.Close SaveChanges:=False
FName = Dir()
Loop
End With
End Sub
Option Explicit
Sub MergeExcels()
Dim Path As String, FName As String
Dim wb As Workbook
Dim ws As Worksheet
Path = "D:\BILL'S\Thankam\2019\June\Bills"
FName = Dir(Path & "*.xlsx")
With ThisWorkbook
Do While FName <> ""
Set wb = Workbooks.Open(Path & FName, ReadOnly:=True)
wb.Worksheets(1).Copy After:=.Sheets(.Sheets.Count)
wb.Close SaveChanges:=False
FName = Dir()
Loop
End With
End Sub