I have an Excel with several sheets I want to export to csv delimited by columns.
When I run the code, it exports the files to csv but comma delimited, not column delimited as I export in csv.
Any help would be appreciated.
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir (MyFilePath & "_csv") '<< 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 ThisWorkbook.path & "\_csv\" & SheetName & ".csv", FileFormat:=xlCSV
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
Thanks!
Edit: Screenshot that clarifies my problem.
https://imgur.com/a/mPn997B
Define FileFormat as xlText and the file will be TAB delimited, which you obviously are looking for.
f.ex.:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Set wb = ActiveWorkbook
wb.SaveAs "c:\tmp\tabtest.csv", xlText
End Sub
Following the instructions in this Stack Overflow question, I tried to run my macro with the following code:
Sub ay1()
Dim fileName, Pathname As String
Dim wb As Workbook
Pathname = "/Users/ayy/Downloads/Folder1/STATS1/"
fileName = Dir(Pathname & "*.csv")
Do While fileName <> ""
Set wb = Workbooks.Open(Pathname & fileName)
DoWork wb
wb.Close SaveChanges:=True
fileName = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$191").AutoFilter Field:=3, Criteria1:="="
Range("C2:C190").Select
Selection.EntireRow.Delete
ActiveSheet.Range("$A$1:$C$96").AutoFilter Field:=3
Range("E95").Select
ActiveWorkbook.Save
ActiveWindow.Close
End With
End Sub
I saved this in a "master workbook" that is macro-enabled in the same directory where all my .csv files are located. I clicked run macro and selected ay1.
This is not running on any of my files. I'm not getting any errors.
Using a With block: you need to tie your references to wb with a leading .
Sub DoWork(wb As Workbook)
With wb.Sheets(1)
.UsedRange.AutoFilter
.Range("$A$1:$C$191").AutoFilter Field:=3, Criteria1:="="
.Range("C2:C190").EntireRow.Delete
.Range("$A$1:$C$96").AutoFilter Field:=3
End With
wb.Save
wb.Close
End Sub
I want to save my file in a particular SharePoint folder when I press a button.
Within the same Excel spreadsheet I have data validation cells that should not be blank. If they are blank the macro should give me an error message and tell me that certain cells are blank and needs to be filled. If they are not blank, then save the file in the SharePoint folder.
My macro is as follows:
Private Sub CommandButton1_Click()
Dim Path As String
Dim FileName1 As String
Path = "https://xxx.sharepoint.com/sites/xxxx/xxxxxxxxxxxxx/"
FileName1 = Range("$B$2").Text
ActiveWorkbook.SaveAs Filename:=Path & FileName1 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
The cells are AD9:AM9 and AD10:AM10
This if statement checks if cells are empty and proceeds to end the macro before saving if the range is empty. I merged your ranges as they are adjacent.
Private Sub CommandButton1_Click()
Dim Path As String
Dim FileName1 As String
If WorksheetFunction.CountA(Range("AD9:AM10")) = 0 Then
MsgBox "Data Validation Fields are empty"
end ' stops the macro from running
Else
Path = "https://xxx.sharepoint.com/sites/xxxx/xxxxxxxxxxxxx/"
FileName1 = Range("$B$2").Text
ActiveWorkbook.SaveAs Filename:=Path & FileName1 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
End if
End Sub
Please use the Workbook_BeforeSave event like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sh As Worksheet, rng As Range, emptRng As Range
Set sh = ActiveSheet 'use here your sheet
Set rng = sh.Range("AD9:AM10")
On Error Resume Next
Set emptRng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number = 0 Then
Cancel = True
MsgBox "There are empty cells in the range " & rng.Address & "." & vbCrLf & _
"Please check, correct and save again after that..."
End If
On Error GoTo 0
End Sub
I am using the below code to create a .txt file from an excel sheet. However it seems to produce another column at the start of the file and I cannot figure out why. Any Help would be appreciated.
A9:M287 are all filled with content also so it is not a hidden blank column.
Sub StoretoTXT()
Dim answer As Integer
answer = MsgBox("Have all the required fields been filled and are correct?", vbYesNo + vbQuestion, "Data Check")
If answer = vbYes Then
Dim c As Range, r As Range
Dim output As String
For Each r In Range("A9:M287").Rows
For Each c In r.Cells
output = output & vbTab & c.Value
Next c
output = output & vbNewLine
Next r
Open "C:\Test\Desktop" & Format(Now(), "YYYYMMDDHHMMSS") & "Test.txt" For Output As #1
Print #1, output
Close
MsgBox "File has now been created. Excel will now close"
ActiveWorkbook.Close False
Else
'do nothing
End If
End Sub
It might be easier to just use the SaveAs method to create a tab-delimited file. Since you're looking only for specific range, first copy that range to a new workbook, and then save as xlText:
Sub SaveAsTabDelimited()
Dim rng as Range
Dim newWB as Workbook
Set rng = Range("A9:M287")
Set newWB = Workbooks.Add
Application.DisplayAlerts = False
With newWB
Do While .Worksheets.Count > 1
.Worksheets(.Worksheets.Count).Delete
Loop
End With
rng.Copy newWB.Worksheets(1).Range("A1")
'## Modify path to file output in the next line:
newWB.SaveAs Filename:="C:\Debug\tab-delimited.txt", FileFormat:= _
xlText, CreateBackup:=False
Application.DisplayAlerts = True
newWB.Close
End Sub
It has been drilled into my head, to avoid bugs and provide a good user experience, it is best to avoid using .Select, .Activate, ActiveSheet,ActiveCell, etc.
Keeping this in mind, is there a way to use the .ExportAsFixedFormat method on a subset of Sheets in a workbook without employing one of the above? So far the only ways I have been able to come up with to do this are to either:
use a For Each; however, this results in separate PDF files, which is no good.
use the code similar to that generated by the macro recorder, which uses .Select and ActiveSheet:
Sheets(Array("Sheet1", "Chart1", "Sheet2", "Chart2")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"exported file.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, openafterpublish:= True
Perhaps it is impossible not to use ActiveSheet, but can I at least get around using .Select somehow?
I have tried this:
Sheets(Array("Sheet1", "Chart1", "Sheet2","Chart2")).ExportAsFixedFormatType:= _
xlTypePDF, Filename:= "exported file.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, openafterpublish:= _
True
This produces:
error 438: Object doesn't support this property or method
Hate to dredge up an old question, but I'd hate to see somebody stumbling across this question resort to the code gymnastics in the other answers. The ExportAsFixedFormat method only exports visible Worksheets and Charts. This is much cleaner, safer, and easier:
Sub Sample()
ToggleVisible False
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
"exported file.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ToggleVisible True
End Sub
Private Sub ToggleVisible(state As Boolean)
Dim ws As Object
For Each ws In ThisWorkbook.Sheets
Select Case ws.Name
Case "Sheet1", "Chart1", "Sheet2", "Chart2"
Case Else
ws.Visible = state
End Select
Next ws
End Sub
It has been drilled into my head (through lots of....
I know what do you MEAN ;)
Here is one way which doesn't use .Select/.Activate/ActiveSheet
Logic:
Delete the unnecessary sheets
Export the entire workbook.
Close the workbook without saving so that you get your deleted sheets back
Code:
Sub Sample()
Dim ws As Object
On Error GoTo Whoa '<~~ Required as we will work with events
'~~> Required so that deleted sheets/charts don't give you Ref# errors
Application.Calculation = xlCalculationManual
For Each ws In ThisWorkbook.Sheets
Select Case ws.Name
Case "Sheet1", "Chart1", "Sheet2", "Chart2"
Case Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Select
Next ws
'~~> Use ThisWorkbook instead of ActiveSheet
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"exported file.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, openafterpublish:=True
LetsContinue:
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
'~~> VERY IMPORTANT! This ensures that you get your deleted sheets back.
ThisWorkbook.Close SaveChanges:=False
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
EDIT: Happy to report that the now current accepted answer has made this idea entirely unnecessary.
Thanks to Siddharth Rout for providing me with the idea for a way to do this!
EDIT: As written below this module mostly works but not entirely; the problem I am having is the charts do not keep their data after the sheets they refer to have been deleted (this is despite the inclusion of the pApp.Calculation = xlCalculationManual command). I haven't been able to figure out how to fix this. Will update when I do.
Below is a class module (implementing the methodology of this answer) to solve this problem. Hopefully it will be useful for someone, or people could offer feedback on it if it doesn't work for them.
WorkingWorkbook.cls
'**********WorkingWorkbook Class*********'
'Written By: Rick Teachey '
'Creates a "working copy" of the desired '
'workbook to be used for any number of '
'disparate tasks. The working copy is '
'destroyed once the class object goes out'
'of scope. The original workbook is not '
'affected in any way whatsoever (well, I '
'hope, anyway!) '
''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private pApp As Excel.Application
Private pWorkBook As Workbook
Private pFullName As String
Property Get Book() As Workbook
Set Book = pWorkBook
End Property
Public Sub Init(CurrentWorkbook As Workbook)
Application.DisplayAlerts = False
Dim NewName As String
NewName = CurrentWorkbook.FullName
'Append _1 onto the file name for the new (temporary) file
Do
NewName = Mid(NewName, 1, InStr(Len(NewName) - 4, NewName, ".") - 1) _
& Replace(NewName, ".", "_1.", Len(NewName) - 4, 1)
'Check if the file already exists; if so, append _1 again
Loop While (Len(Dir(NewName)) <> 0)
'Save the working copy file
CurrentWorkbook.SaveCopyAs NewName
'Open the working copy file in the background
pApp.Workbooks.Open NewName
'Set class members
Set pWorkBook = pApp.Workbooks(Dir(NewName))
pFullName = pWorkBook.FullName
Application.DisplayAlerts = True
End Sub
Private Sub Class_Initialize()
'Do all the work in the background
Set pApp = New Excel.Application
'This is the default anyway so probably unnecessary
pApp.Visible = False
'Could probably do without this? Well just in case...
pApp.DisplayAlerts = False
'Workaround to prevent the manual calculation line from causing an error
pApp.Workbooks.Add
'Prevent anything in the working copy from being recalculated when opened
pApp.Calculation = xlCalculationManual
'Also probably unncessary, but just in case
pApp.CalculateBeforeSave = False
'Two more unnecessary steps, but it makes me feel good
Set pWorkBook = Nothing
pFullName = ""
End Sub
Private Sub Class_Terminate()
'Close the working copy (if it is still open)
If Not pWorkBook Is Nothing Then
On Error Resume Next
pWorkBook.Close savechanges:=False
On Error GoTo 0
Set pWorkBook = Nothing
End If
'Destroy the working copy on the disk (if it is there)
If Len(Dir(pFullName)) <> 0 Then
Kill pFullName
End If
'Quit the background Excel process and tidy up (if needed)
If Not pApp Is Nothing Then
pApp.Quit
Set pApp = Nothing
End If
End Sub
Testing Procedure
Sub test()
Dim wwb As WorkingWorkbook
Set wwb = New WorkingWorkbook
Call wwb.Init(ActiveWorkbook)
Dim wb As Workbook
Set wb = wwb.Book
Debug.Print wb.FullName
End Sub
An option, without creating a new WB:
Option Explicit
Sub fnSheetArrayPrintToPDF()
Dim strFolderPath As String
Dim strSheetNamesList As String
Dim varArray() As Variant
Dim bytSheet As Byte
Dim strPDFFileName As String
Dim strCharSep As String
strCharSep = ","
strPDFFileName = "SheetsPrinted"
strSheetNamesList = ActiveSheet.Range("A1")
If Trim(strSheetNamesList) = "" Then
MsgBox "Sheet list is empty. Check it. > ActiveSheet.Range(''A1'')"
GoTo lblExit
End If
For bytSheet = 0 To UBound(Split(strSheetNamesList, strCharSep, , vbTextCompare))
ReDim Preserve varArray(bytSheet)
varArray(bytSheet) = Trim(Split(strSheetNamesList, strCharSep, , vbTextCompare)(bytSheet))
Next
strFolderPath = Environ("USERPROFILE") & "\Desktop\pdf\"
On Error Resume Next
MkDir strFolderPath
On Error GoTo 0
If Dir(strFolderPath, vbDirectory) = "" Then
MsgBox "Err attempting to create the folder: '" & strFolderPath & "'."
GoTo lblExit
End If
Sheets(varArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFolderPath & strPDFFileName, _
OpenAfterPublish:=False, IgnorePrintAreas:=False
MsgBox "Print success." & vbNewLine & " Folder: " & strFolderPath, vbExclamation, "Printing to PDF"
lblExit:
Exit Sub
End Sub