 | 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.
VBA Code: ***********
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
************************* |
|