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
Related
There is a simple macro that copies all the data on a defined worksheet and saves it in .txt format. The problem is that the decimal number in one of the columns is not separated by a comma but by a dot during the save. I would like to eliminate this somehow, but so far all my attempts have been in vain.
VBA code:
Dim myPath As String, myFile As String
myPath = ThisWorkbook.Path & "\"
myFile = Application.UserName + "_SAP_árlista_betöltő_" + Format(Now(), "YYYY_MM_DD_hhmmss") & ".txt"
Dim WB As Workbook, newWB As Workbook
Set WB = ThisWorkbook
Application.ScreenUpdating = False
Set newWB = Workbooks.Add
WB.ActiveSheet.UsedRange.Copy newWB.Sheets(1).Range("A1")
With newWB
Application.DisplayAlerts = False
.SaveAs Filename:=myPath & myFile, FileFormat:=xlTextWindows
.Close True
Application.DisplayAlerts = True
End With
WB.Save
Application.ScreenUpdating = True
Range("A1:J670").Select
Selection.ClearContents
Range("A1").Select
MsgBox "Az adatok mentésre kerültek!"
End Sub
Thanks for the tips!
Geri
In the end, that's how I managed to solve it.
Dim rngData As Range
Dim strData As String
Dim strTempFile As String
Set rngData = ActiveSheet.UsedRange
rngData.Copy
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
strData = .GetText
End With
strTempFile = Application.DefaultFilePath & "\" & Application.UserName + "_SAP_árlista_betöltő_" + Format(Now(), "YYYY_MM_DD_hhmmss") & ".txt"
With CreateObject("Scripting.FileSystemObject")
.CreateTextFile(strTempFile, True).Write strData
End With
End Sub
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
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
I am using this code which works fine but it also copies:
Formulas
Shapes
Macros embedded on Sheet
I am looking for a way to only copy the values of the sheet, whilst retaining their original formatting and then close the newly created workbook as my macro does.
Sub export_sheet()
Dim sourceWB As Workbook
Dim destWB As Workbook
Dim strSourceSheet As Worksheet
Dim strname As String
Dim path As String
Application.DisplayAlerts = False
path = ThisWorkbook.path & "\"
strname = "test_" & Format(Now, "dd_mmm_yy_hh_mm_ss") & ".xlsx"
Set strSourceSheet = ActiveSheet
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=path & strname, FileFormat:=51, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim rFirst As Range
Dim rLast As Range
Dim rDest As Range
Dim sFolderPath As String
Dim sFileName As String
Set wb = ThisWorkbook
Set wsCopy = wb.ActiveSheet
Set rFirst = wsCopy.Cells.Find("*", wsCopy.Cells(wsCopy.Rows.Count, wsCopy.Columns.Count), xlValues, xlPart, , xlNext)
Set rLast = wsCopy.Cells.Find("*", wsCopy.Range("A1"), xlValues, xlPart, , xlPrevious)
sFolderPath = ThisWorkbook.Path & Application.PathSeparator
sFileName = "test_" & Format(Now, "dd_mmm_yy_hh_mm_ss") & ".xlsx"
wb.Worksheets.Add.Move 'create new workbook with a blank worksheet
Set wsDest = ActiveWorkbook.ActiveSheet 'the newly created workbook and sheet will be active because they were just created
With wsDest
Set rDest = .Cells(rFirst.Row, rFirst.Column)
wsCopy.Range(rFirst, rLast).Copy
rDest.PasteSpecial xlPasteValues
rDest.PasteSpecial xlPasteFormats
rDest.PasteSpecial xlPasteColumnWidths
.Parent.SaveAs sFolderPath & sFileName, xlOpenXMLWorkbook
.Parent.Close True
End With
End Sub
Try this:
Sub export_sheet()
Dim sourceWB As String
Dim destWB As String
Dim strSourceSheet As String
Dim strname As String
Dim path As String
Application.DisplayAlerts = False
path = ThisWorkbook.path & "\"
strname = "test_" & Format(Now, "dd_mmm_yy_hh_mm_ss") & ".xlsx"
strSourceSheet = ActiveSheet.Name
sourceWB = Activeworkbook.Name
Sheets(strSourceSheet).Copy
‘If want to copy yo new wb
Workbooks.Add
DestWB = Activeworkbook.Name
‘Or if DestWb already exists then
‘DestWB = yourdestinationwb.xlsx
‘Windows(DestWB).Activate
‘Sheets(1).Select
Activesheet.Range(“A1”).SeLect
Selection.PasteSpecial Paste:=XlPasteValues
Selection.PasteSpecial Paste:=XlPasteFormats
ActiveWorkbook.SaveAs Filename:=path & strname, FileFormat:=51, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
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