Unable to Export Excel data to a Flat File

B

Bobby

I am trying to convert all the work sheet data to a flat file. But when i am
trying am getting that export failed. Please help to resolve this issue.

Iam getting "Export failed" when i call this ExportToFile() function using a
menu.
the function GetDefaultFileName() is previously i used to convert the single
worksheet data into a flat file. But now i need to convert the all worksheets
to the multiple flatfiles when i call this 'ExportToFile() function.


***********
Option Explicit

Public Sub ExportToFile()
On Error GoTo ErrorHandler

Dim ts As TextStream
Dim fileName As String, fileContent As String, tableName As String,
delimiter As String
Dim rowCount As Long, columnCount As Long, dataColumn As Long, pageSize
As Long
Dim pageNumber As Integer
Dim tempRange As Range, tempCell As Range

fileName = GetDefaultFileName()
If fileName = "" Then Exit Sub

If Not EnsureTitle() Then Exit Sub

fileName = Application.GetSaveAsFilename(fileName, "Data Files
(*.txt),*.txt", _
1, "Save Data File", "Export")

If fso.FileExists(fileName) Then
If MsgBox("The file " & fso.GetFileName(fileName) & " already
exists. Do " & _
"you want to replace the existing file?", vbYesNo +
vbExclamation + _
vbDefaultButton2, PROJECT_NAME) = vbNo Then
Exit Sub
End If
End If

If fileName <> "False" Then
ActiveWorkbook.Worksheets("Anvil").Cells.ClearContents
columnCount = GetColumnCount
pageNumber = 1
pageSize = MAX_CONCAT_COL
delimiter = GetDelimiter(ActiveSheet.CodeName)
Do While (pageNumber - 1) * pageSize < columnCount
Set tempRange = ActiveWorkbook.Worksheets("Anvil").Cells(1,
pageNumber)
With tempRange
.NumberFormat = "General"
.FormulaR1C1 = ConcatFunction(delimiter, pageNumber,
pageSize, columnCount)
End With
pageNumber = pageNumber + 1
Loop

If pageNumber > 2 Then
Set tempRange = ActiveWorkbook.Worksheets("Anvil").Cells(1,
pageNumber)
With tempRange
.NumberFormat = "General"
.FormulaR1C1 = MasterConcatFunction(pageNumber - 1)
End With
dataColumn = pageNumber
Else
dataColumn = 1
End If

rowCount = GetRowCount

If rowCount > 1 Then
Range(ActiveWorkbook.Worksheets("Anvil").Cells(1, 1), _
ActiveWorkbook.Worksheets("Anvil").Cells(rowCount,
dataColumn)).FillDown
End If

Set ts = fso_OpenTextFile(fileName, ForWriting, True)
With Range(ActiveWorkbook.Worksheets("Anvil").Cells(1, dataColumn), _
ActiveWorkbook.Worksheets("Anvil").Cells(rowCount, dataColumn))
For Each tempCell In .Cells
If tempCell.Row < rowCount Then
Call ts.WriteLine(tempCell.Value)
Else
Call ts.Write(tempCell.Value)
End If
Next
End With
ActiveWorkbook.Worksheets("Anvil").Cells.ClearContents
ts.Close
Else
Exit Sub
End If


Exit Sub
ErrorHandler:
ActiveSheet.Columns((GetColumnCount + 1)).ClearContents
MsgBox MSG2002, vbOKOnly + vbCritical, PROJECT_NAME
End Sub


Private Function ConcatFunction(delimiter As String, pageNumber As Integer, _
pageSize As Long, columnCount As Long) As String
Dim index As Integer, startIndex As Integer, endIndex As Integer
Dim concatString As String, sheetName As String

sheetName = ActiveSheet.Name
concatString = "="
startIndex = (pageNumber - 1) * pageSize + 1 - pageNumber
endIndex = IIf(columnCount < pageNumber * pageSize, _
columnCount - pageNumber, pageNumber * (pageSize - 1))

For index = startIndex To endIndex
concatString = concatString & " '" & Replace(sheetName, "'", "''") & _
"'!RC[" & index & "] & ""~"""
If index < endIndex Then concatString = concatString & " & "
Next

ConcatFunction = concatString
Exit Function
End Function


Private Function GetDefaultFileName() As String
Dim sheetName As String, tableName As String, tagName As String
Dim tempRange As Range
Dim position As Integer

sheetName = ActiveSheet.Name
tableName = GetTableName(ActiveSheet.CodeName)

If tableName = "" Then
position = InStr(sheetName, "_")
If position > 0 Then
tagName = Left(sheetName, position - 1)
Else
tagName = sheetName
End If

Set tempRange =
Application.Names("Entities").RefersToRange.Offset(0, 1).Find( _
What:=tagName, LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then
tagName = ""
Else
UpdateImportList ActiveSheet.CodeName, tempRange.Previous.Value
End If
Else
Set tempRange = Application.Names("Entities").RefersToRange.Find( _
What:=tableName, LookIn:=xlValues, LookAt:=xlWhole)

If Not (tempRange Is Nothing) Then _
tagName = tempRange.Next.Value
End If

If tagName <> "" Then
If StrComp(tagName, sheetName, vbTextCompare) = 0 Or _
InStr(1, sheetName, tagName & "_", vbTextCompare) = 1 Then
GetDefaultFileName = sheetName
Else
GetDefaultFileName = tagName & "_xxx"
End If
Else
Set tempRange = ActiveWorkbook.Names("CurrentTag").RefersToRange
tempRange.Value = 1
ActiveWorkbook.Names.Add Name:="Tags",
RefersToR1C1:="=Entities!R3C2:R" & _
ActiveWorkbook.Sheets("Entities").Range("B2").End(xlDown).Row &
"C2"
ActiveWorkbook.DialogSheets("TagDialog").Show
If tempRange.Value = "" Then
GetDefaultFileName = ""
Exit Function
End If
tagName =
WorksheetFunction.index(Application.Names("Entities").RefersToRange.Offset(0,
1), _
tempRange.Value, 1)

tableName =
WorksheetFunction.index(Application.Names("Entities").RefersToRange, _
tempRange.Value, 1)
UpdateImportList ActiveSheet.CodeName, tableName

GetDefaultFileName = tagName & "_xxx"
End If

End Function


Sub Cancel_Click()
ActiveWorkbook.Names("CurrentTag").RefersToRange.Value = ""
End Sub


Public Function GetColumnCount() As Integer
Dim tempRange As Range

If ActiveSheet.Range("A1").Value = "" Then
GetColumnCount = 0
Else
GetColumnCount = _

ActiveSheet.Range("A1").End(xlToRight).End(xlToRight).End(xlToLeft).Column
End If

End Function

Private Function GetRowCount() As Long
GetRowCount = ActiveSheet.UsedRange.Rows.Count
End Function


Private Function EnsureTitle() As Boolean
Dim tableName As String, keyColumn As String
Dim tempRange As Range

tableName = GetTableName(ActiveSheet.CodeName)
Set tempRange = Application.Names("Entities").RefersToRange.Find( _
What:=tableName, LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then Exit Function
keyColumn = tempRange.Offset(0, 2).Value
Set tempRange = Range(ActiveSheet.Range("A1"), _
ActiveSheet.Cells(1, GetColumnCount)).Find(What:=keyColumn, _
LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then
' If MsgBox(MSG2001, vbQuestion + vbDefaultButton2 + vbYesNo,
PROJECT_NAME) = _
' vbYes Then EnsureTitle = ImportControlFile(False)
MsgBox MSG2001, vbCritical + vbDefaultButton2 + vbOKOnly, PROJECT_NAME
ActiveWindow.FreezePanes = False
ActiveWindow.SplitRow = 0
EnsureTitle = False
Else
EnsureTitle = True
End If


End Function


Private Function MasterConcatFunction(pageCount As Integer) As String
Dim index As Integer
Dim concatString As String

concatString = "="
For index = pageCount To 1 Step -1
concatString = concatString & " RC[-" & index & "]"
If index > 1 Then concatString = concatString & " & "
Next

MasterConcatFunction = concatString
Exit Function
End Function
*************************
 
J

Jeff Boyce

Your question seems to imply using Excel.

This newsgroup supports the use of MS Access.

You might want to try posting to an Excel newsgroup...

Regards

Jeff Boyce
Microsoft Office/Access MVP


Bobby said:
I am trying to convert all the work sheet data to a flat file. But when i
am
trying am getting that export failed. Please help to resolve this issue.

Iam getting "Export failed" when i call this ExportToFile() function using
a
menu.
the function GetDefaultFileName() is previously i used to convert the
single
worksheet data into a flat file. But now i need to convert the all
worksheets
to the multiple flatfiles when i call this 'ExportToFile() function.


***********
Option Explicit

Public Sub ExportToFile()
On Error GoTo ErrorHandler

Dim ts As TextStream
Dim fileName As String, fileContent As String, tableName As String,
delimiter As String
Dim rowCount As Long, columnCount As Long, dataColumn As Long, pageSize
As Long
Dim pageNumber As Integer
Dim tempRange As Range, tempCell As Range

fileName = GetDefaultFileName()
If fileName = "" Then Exit Sub

If Not EnsureTitle() Then Exit Sub

fileName = Application.GetSaveAsFilename(fileName, "Data Files
(*.txt),*.txt", _
1, "Save Data File", "Export")

If fso.FileExists(fileName) Then
If MsgBox("The file " & fso.GetFileName(fileName) & " already
exists. Do " & _
"you want to replace the existing file?", vbYesNo +
vbExclamation + _
vbDefaultButton2, PROJECT_NAME) = vbNo Then
Exit Sub
End If
End If

If fileName <> "False" Then
ActiveWorkbook.Worksheets("Anvil").Cells.ClearContents
columnCount = GetColumnCount
pageNumber = 1
pageSize = MAX_CONCAT_COL
delimiter = GetDelimiter(ActiveSheet.CodeName)
Do While (pageNumber - 1) * pageSize < columnCount
Set tempRange = ActiveWorkbook.Worksheets("Anvil").Cells(1,
pageNumber)
With tempRange
.NumberFormat = "General"
.FormulaR1C1 = ConcatFunction(delimiter, pageNumber,
pageSize, columnCount)
End With
pageNumber = pageNumber + 1
Loop

If pageNumber > 2 Then
Set tempRange = ActiveWorkbook.Worksheets("Anvil").Cells(1,
pageNumber)
With tempRange
.NumberFormat = "General"
.FormulaR1C1 = MasterConcatFunction(pageNumber - 1)
End With
dataColumn = pageNumber
Else
dataColumn = 1
End If

rowCount = GetRowCount

If rowCount > 1 Then
Range(ActiveWorkbook.Worksheets("Anvil").Cells(1, 1), _
ActiveWorkbook.Worksheets("Anvil").Cells(rowCount,
dataColumn)).FillDown
End If

Set ts = fso_OpenTextFile(fileName, ForWriting, True)
With Range(ActiveWorkbook.Worksheets("Anvil").Cells(1, dataColumn),
_
ActiveWorkbook.Worksheets("Anvil").Cells(rowCount, dataColumn))
For Each tempCell In .Cells
If tempCell.Row < rowCount Then
Call ts.WriteLine(tempCell.Value)
Else
Call ts.Write(tempCell.Value)
End If
Next
End With
ActiveWorkbook.Worksheets("Anvil").Cells.ClearContents
ts.Close
Else
Exit Sub
End If


Exit Sub
ErrorHandler:
ActiveSheet.Columns((GetColumnCount + 1)).ClearContents
MsgBox MSG2002, vbOKOnly + vbCritical, PROJECT_NAME
End Sub


Private Function ConcatFunction(delimiter As String, pageNumber As
Integer, _
pageSize As Long, columnCount As Long) As String
Dim index As Integer, startIndex As Integer, endIndex As Integer
Dim concatString As String, sheetName As String

sheetName = ActiveSheet.Name
concatString = "="
startIndex = (pageNumber - 1) * pageSize + 1 - pageNumber
endIndex = IIf(columnCount < pageNumber * pageSize, _
columnCount - pageNumber, pageNumber * (pageSize - 1))

For index = startIndex To endIndex
concatString = concatString & " '" & Replace(sheetName, "'", "''")
& _
"'!RC[" & index & "] & ""~"""
If index < endIndex Then concatString = concatString & " & "
Next

ConcatFunction = concatString
Exit Function
End Function


Private Function GetDefaultFileName() As String
Dim sheetName As String, tableName As String, tagName As String
Dim tempRange As Range
Dim position As Integer

sheetName = ActiveSheet.Name
tableName = GetTableName(ActiveSheet.CodeName)

If tableName = "" Then
position = InStr(sheetName, "_")
If position > 0 Then
tagName = Left(sheetName, position - 1)
Else
tagName = sheetName
End If

Set tempRange =
Application.Names("Entities").RefersToRange.Offset(0, 1).Find( _
What:=tagName, LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then
tagName = ""
Else
UpdateImportList ActiveSheet.CodeName, tempRange.Previous.Value
End If
Else
Set tempRange = Application.Names("Entities").RefersToRange.Find( _
What:=tableName, LookIn:=xlValues, LookAt:=xlWhole)

If Not (tempRange Is Nothing) Then _
tagName = tempRange.Next.Value
End If

If tagName <> "" Then
If StrComp(tagName, sheetName, vbTextCompare) = 0 Or _
InStr(1, sheetName, tagName & "_", vbTextCompare) = 1 Then
GetDefaultFileName = sheetName
Else
GetDefaultFileName = tagName & "_xxx"
End If
Else
Set tempRange = ActiveWorkbook.Names("CurrentTag").RefersToRange
tempRange.Value = 1
ActiveWorkbook.Names.Add Name:="Tags",
RefersToR1C1:="=Entities!R3C2:R" & _
ActiveWorkbook.Sheets("Entities").Range("B2").End(xlDown).Row &
"C2"
ActiveWorkbook.DialogSheets("TagDialog").Show
If tempRange.Value = "" Then
GetDefaultFileName = ""
Exit Function
End If
tagName =
WorksheetFunction.index(Application.Names("Entities").RefersToRange.Offset(0,
1), _
tempRange.Value, 1)

tableName =
WorksheetFunction.index(Application.Names("Entities").RefersToRange, _
tempRange.Value, 1)
UpdateImportList ActiveSheet.CodeName, tableName

GetDefaultFileName = tagName & "_xxx"
End If

End Function


Sub Cancel_Click()
ActiveWorkbook.Names("CurrentTag").RefersToRange.Value = ""
End Sub


Public Function GetColumnCount() As Integer
Dim tempRange As Range

If ActiveSheet.Range("A1").Value = "" Then
GetColumnCount = 0
Else
GetColumnCount = _

ActiveSheet.Range("A1").End(xlToRight).End(xlToRight).End(xlToLeft).Column
End If

End Function

Private Function GetRowCount() As Long
GetRowCount = ActiveSheet.UsedRange.Rows.Count
End Function


Private Function EnsureTitle() As Boolean
Dim tableName As String, keyColumn As String
Dim tempRange As Range

tableName = GetTableName(ActiveSheet.CodeName)
Set tempRange = Application.Names("Entities").RefersToRange.Find( _
What:=tableName, LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then Exit Function
keyColumn = tempRange.Offset(0, 2).Value
Set tempRange = Range(ActiveSheet.Range("A1"), _
ActiveSheet.Cells(1, GetColumnCount)).Find(What:=keyColumn, _
LookIn:=xlValues, LookAt:=xlWhole)

If tempRange Is Nothing Then
' If MsgBox(MSG2001, vbQuestion + vbDefaultButton2 + vbYesNo,
PROJECT_NAME) = _
' vbYes Then EnsureTitle = ImportControlFile(False)
MsgBox MSG2001, vbCritical + vbDefaultButton2 + vbOKOnly,
PROJECT_NAME
ActiveWindow.FreezePanes = False
ActiveWindow.SplitRow = 0
EnsureTitle = False
Else
EnsureTitle = True
End If


End Function


Private Function MasterConcatFunction(pageCount As Integer) As String
Dim index As Integer
Dim concatString As String

concatString = "="
For index = pageCount To 1 Step -1
concatString = concatString & " RC[-" & index & "]"
If index > 1 Then concatString = concatString & " & "
Next

MasterConcatFunction = concatString
Exit Function
End Function
*************************
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Unable to Convert WorkSheets Data to Flat Files 1
Unable to Convert WorkSheets data to Flkat Files 0
YYY-MM-DD format is changing when convert data to Flat File 3
unable to Find the size of the file throwing exception 1
Word macro that can call cells out of Excel for a find and replace 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Excel crashes and restarts when accessing newly created worksheet 2
unable to create a file if already exiists 2

Top