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
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
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
I would like to combine sheets with the same name & format from multiple files into a single summary sheet. I used this code to do it but I found it won't copy any filtered data or link cells. I also tried a couple codes to remove the filter, and the copied data becomes uncontinuous. Could someone look into this and help me? Thanks!
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
MsgBox "All done.", vbInformation, "bingo"
End Sub
This is a bit of a brute force method, but seems to work:
Sub Summarize()
Dim sourcePath As String
Dim sourceName As String
Dim sourceWorkbook as Workbook ' Workbook to be copied
Dim sourceSheet as Worksheet
Dim thisWorkbookName as String
Dim copyCell as Range
Dim sourceBase as Range ' Summary starts here
Application.ScreenUpdating = False
sourcePath = ActiveWorkbook.Path
thisWorkbookName = ActiveWorkbook.Name
sourceName = Dir(MyPath & "\" & "*.xlsm")
Set sourceBase = Workbooks(1).ActiveSheet.Range("A1") ' Set to what you want
Do While sourceName <> ""
If sourceName <> thisWorkbookName Then
Set sourceWorkbook = Workbooks.Open(sourcePath & "\" & sourceName)
Set sourceSheet = sourceWorkbook.Sheets(13)
For Each copyCell In sourceSheet.UsedRange
copyCell.Copy sourceBase.Offset(copyCell.Row - 1, copyCell.Column - 1)
Next
Set sourceBase = sourceBase.Offset(sourceSheet.UsedRange.Rows.Count)
Set copyCell = Nothing
Set sourceSheet = Nothing
sourceWorkbook.Close False
End If
sourceName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
End Sub
I'm just manually copying every cell in the used range into the target sheet. The base cell gets reset after each sheet, so it should just keep appending to the target sheet.
Caveat
I've only tested the inner code in my own sheet. I made adjustments on the fly to fit everything into your original logic. The entire function above should replace your original function. If you have errors, it's because I mistyped something. My apologies.
I set the autofiltermode to False. This worked in my case.
Wb.Sheets(13).AutoFilterMode = False
Here is the modified code.
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Wb.Sheets(13).AutoFilterMode = False
ThisWorkbook.Activate
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
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