I'm trying to export an Excel page to a .txt file. Row one has a header. This is not being exported, but I need to do.
Here is my code so far. It does everything I need but include the row of column headers, such as Name, Address, Age, etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExportToTextFile
' This exports a sheet or range to a text file, using a
' user-defined separator character.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Sheets("Export").Visible = True
Sheets("Export").Select
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If .Value <> "GEN" Then .EntireRow.Delete
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END ExportTextFile
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DoTheExport
' This prompts the user for the FileName and the separtor
' character and then calls the ExportToTextFile procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DoTheExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
Debug.Print "FileName: " & FileName, "Separator: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=True
Sheets("Export").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFill Destination:=Range("A1:M500")
Range("A1:M500").Select
Range("A1").Select
ActiveWindow.SelectedSheets.Visible = False
End Sub
Perhaps you are deleting the headings row because "Name" <> "GEN"
If .Value = "ron" Then .EntireRow.Delete
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
Related
I do not know what I am doing wrong. The code will run but it does not copy the data as expected, all the values seem to be overwriting to row 1 on the target sheet (tsht) instead of copying data down the target sheet. The goal here is to take data and iterate it for every county listed on the group ID tab (captured by SubCell.Value). Where plan codes and term dates match, the macro should copy each matching row from dsht for the indicated number of counties on gsht to the tsht. Can anyone see my error or why this code is keeping data all in the top row of the tsht?
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",")
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then
For i = 1 To countycount
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
tsht.Range("L" & tlrow).Value = Result(a)
i = i + 1
Next
a = a + 1
End If
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub
This has been resolved with the below code, I wanted to post the resolution in case anyone finds a way to make this code work for them. Sorry I couldn't get this to copy over as clean as my 1st block.
Solution:
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
'pull header from dsht to tsht
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",") 'separates a list of counties by comma to reference as "Result(0)"
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
i = 1
For i = 1 To countycount
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then 'match dates and plan codes
'move row where match is found between dsht and gsht variables
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
tsht.Range("A" & (tlrow + 1)).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
'place county names captured by split above with each iteration
tsht.Range("L" & (tlrow + 1)).Value = Result(a)
End If
a = a + 1
Next i
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub
tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value =
should be
tsht.Range("A" & (tlrow+1)).Resize(.Rows.Count, .Columns.Count).Value =
I cannot find the named range or reference that is invalid, according to Excel. I checked my named ranges, including ranges within charts. The excel file contains a macro that creates a report that works fine when launched within the file itself. However, if I call that function from another workbook to run the report that is when I get the error message of invalid references. When going through the reports created both directly and indirectly they seem identical. Setting Application.DisplayAlerts = False does not work.
I tried using the code below from from Allen Wyatt to go through all reference and none refer to outside sheets nor contain any errors.
Sub CheckReferences()
' Check for possible missing or erroneous links in
' formulas and list possible errors in a summary sheet
Dim iSh As Integer
Dim sShName As String
Dim sht As Worksheet
Dim c, sChar As String
Dim rng As Range
Dim i As Integer, j As Integer
Dim wks As Worksheet
Dim sChr As String, addr As String
Dim sFormula As String, scVal As String
Dim lNewRow As Long
Dim vHeaders
vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula")
'check if 'Summary' worksheet is in workbook
'and if so, delete it
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Summary" Then
Worksheets(i).Delete
End If
Next i
iSh = Worksheets.Count
'create a new summary sheet
Sheets.Add After:=Sheets(iSh)
Sheets(Sheets.Count).Name = "Summary"
With Sheets("Summary")
Range("A1:D1") = vHeaders
End With
lNewRow = 2
' this will not work if the sheet is protected,
' assume that sheet should not be changed; so ignore it
On Error Resume Next
For i = 1 To iSh
sShName = Worksheets(i).Name
Application.Goto Sheets(sShName).Cells(1, 1)
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)
For Each c In rng
addr = c.Address
sFormula = c.Formula
scVal = c.Text
For j = 1 To Len(c.Formula)
sChr = Mid(c.Formula, j, 1)
If sChr = "[" Or sChr = "!" Or _
IsError(c) Then
'write values to summary sheet
With Sheets("Summary")
.Cells(lNewRow, 1) = sShName
.Cells(lNewRow, 2) = addr
.Cells(lNewRow, 3) = scVal
.Cells(lNewRow, 4) = "'" & sFormula
End With
lNewRow = lNewRow + 1
Exit For
End If
Next j
Next c
Next i
' housekeeping
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
' tidy up
Sheets("Summary").Select
Columns("A:D").EntireColumn.AutoFit
Range("A1:D1").Font.Bold = True
Range("A2").Select
End Sub
It seems that the Workbook.SaveAs method does not support appending to file (otherwise I could slightly modify one of the common solutions).
I know I can use the Open statement and write line by line, but I prefer a more high-level solution.
Based on this answer, here is a line-by-line solution with vbTab as delimiter:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim txtPath As String
Dim FirstSheet As Boolean
Application.ScreenUpdating = False
txtPath = ActiveWorkbook.FullName
txtPath = Replace(txtPath, "xlsm", "txt")
nFileNum = FreeFile
FirstSheet = True
For Each wsSheet In Worksheets
If FirstSheet = True Then
' Overwrite
Open txtPath For Output As #nFileNum
Else
' Append
Open txtPath For Append As #nFileNum
End If
wsSheet.Activate
ExportToTextFile CStr(nFileNum), vbTab, False, Not (FirstSheet)
Close #nFileNum
FirstSheet = False
Next wsSheet
Application.ScreenUpdating = True
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean, _
SkipHeader As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
If SkipHeader = True Then
StartRow = StartRow + 1
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
End Sub
I'm a VBA newbie and did not write this code, credit goes to Ron de Bruin. I'm using it to retrieve the value from whichever cells I enter into the Range - line 12, from whichever files I select. It works with cell locations but all my files have different locations for the defined names. But when I put a defined name into the range, ie. Set rng = Range("cName1") it doesn't work. So basically how would I modify it so I can put a named range in (but also works with a cell location if possible...) Thank you in advance for any help!!
Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
ShName = "Sheet1" '<---- Change
Set Rng = Range("D4:D20") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub
I am glad to be here with great programmers and hope I will learn a lot. I am also new in this kind of programming so I am sorry for any inconvenience.
I am using the vba code below to transfer my files from XLS into CSV. After it translates the xls file into csv format, it saves automatically my newly created csv file in the same directory as my original xls file.
I would like to have a Save As option for my csv filename
Thank you in advance.
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Probably the problem is here. This part of code has to be re-writen or corrected.
This is the main function which calls other ones.
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
This updated code gives you a SaveAs name option (with a default as WorkbookName.csv)
More efficient code using variant arrays to make your csv below.
These are the three key updated lines:
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
updated code
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Dim strFileName As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Long
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
more efficient csv code
From Creating and Writing to a CSV File Using Excel VBA
This code must be run from a regular VBA Code Module. Otherwise the code will cause an error if users try to run it from the ThisWorkbook or Sheet Code panes given the usage of Const.
It is worth noting that the ThisWorkbook and Sheet code sections should be reserved for Event coding only, "normal" VBA should be run from standard Code Modules.
Please note that for purposes of the sample code, the file path of the CSV output file is "hard-coded" as: C:\test\myfile.csv at the top of the code. You will probably want to set the output file programmatically, for instance as a function parameter.
As mentioned earlier; For example purposes, this code TRANSPOSES COLUMNS AND ROWS; that is, the output file contains one CSV row for each column in the selected range. Normally, CSV output would be row-by-row, echoing the layout visible on screen, but I wanted to demonstrate that generating the output by using VBA code provides options beyond what is available by, for instance, using the Save As... CSV Text menu option.
code
Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","
Sub CreateCSV_Output()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
lFnum = FreeFile
Open sFilePath For Output As lFnum
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
Print #lFnum, strTmp
Next lCol
Else
Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
Close lFnum
MsgBox "Done!", vbOKOnly
End Sub
Sub CreateCSV_FSO()
Dim objFSO
Dim objTF
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile(sFilePath, True, False)
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
objTF.writeline strTmp
Next lCol
Else
objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
objTF.Close
Set objFSO = Nothing
MsgBox "Done!", vbOKOnly
End Sub