phio3nix
11-30-2011, 08:30 PM
I found the code of Mr. Charles H. Pearson in his site and made some revisions. Through this code, It only exports the selected rows and columns from the first sheet. My problem is how selected rows and columns from multiple sheets be exported to one csv file. Hope someone can help me with this issue. Thanks.
Here's my code:
Sub FormattedDoTheExport()
Dim filename As Variant
Dim Sep As String
'prompt to ask where and what to call the exported file using Windows built in File Explorer
filename = Application.GetSaveAsFilename(InitialFileName:="Test-" & _
Format(Date, "mm-dd-yy"), fileFilter:="CSV Files (*.csv),*.csv")
If filename = False Then
'user clicked the cancel button, so exit
Exit Sub
End If
' defining the file seperator, which is a comma
Sep = ","
If Sep = vbNullString Then
'seperator not defined, so exit
Exit Sub
End If
Debug.Print "FileName: " & filename, "Separator: " & Sep
' pass in from this sub the actual data to save
ExportToTextFile fname:=CStr(filename), Sep:=CStr(Sep), SelectionOnly:=False, AppendData:=False
' tell the user we've saved the file ok
MsgBox "File Exported.", vbOKOnly, "File Exported."
Exit Sub
End Sub
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
Dim sht As Excel.Worksheet
' suppress screen flicker by turning off the updating of the screen
Application.ScreenUpdating = False
FNum = FreeFile
' export only a selection
For Each sht In ThisWorkbook.Worksheets
If sht.Name = "" Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.count).Row
EndCol = .Cells(.Cells.count).Column
End With
ElseIf sht.Name = "ꗗ" Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.count).Row
EndCol = .Cells(.Cells.count).Column
End With
End If
Next sht
' to add the data at the bottom of an existing file
If AppendData = True Then
Open fname For Append Access Write As #FNum
Else
' to create a new file overwriting if data exists already in the file
Open fname For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
' if blank
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = Chr(34) & Chr(34)
' if a number
ElseIf IsNumeric(Cells(RowNdx, ColNdx)) Then
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
' if a date
ElseIf IsDate(Cells(RowNdx, ColNdx)) Then
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
' if it is anything else
Else
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
' turn screen updating back on
Application.ScreenUpdating = True
Close #FNum
End Sub
Please see the attachment for the excel file :yes
Here's my code:
Sub FormattedDoTheExport()
Dim filename As Variant
Dim Sep As String
'prompt to ask where and what to call the exported file using Windows built in File Explorer
filename = Application.GetSaveAsFilename(InitialFileName:="Test-" & _
Format(Date, "mm-dd-yy"), fileFilter:="CSV Files (*.csv),*.csv")
If filename = False Then
'user clicked the cancel button, so exit
Exit Sub
End If
' defining the file seperator, which is a comma
Sep = ","
If Sep = vbNullString Then
'seperator not defined, so exit
Exit Sub
End If
Debug.Print "FileName: " & filename, "Separator: " & Sep
' pass in from this sub the actual data to save
ExportToTextFile fname:=CStr(filename), Sep:=CStr(Sep), SelectionOnly:=False, AppendData:=False
' tell the user we've saved the file ok
MsgBox "File Exported.", vbOKOnly, "File Exported."
Exit Sub
End Sub
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
Dim sht As Excel.Worksheet
' suppress screen flicker by turning off the updating of the screen
Application.ScreenUpdating = False
FNum = FreeFile
' export only a selection
For Each sht In ThisWorkbook.Worksheets
If sht.Name = "" Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.count).Row
EndCol = .Cells(.Cells.count).Column
End With
ElseIf sht.Name = "ꗗ" Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.count).Row
EndCol = .Cells(.Cells.count).Column
End With
End If
Next sht
' to add the data at the bottom of an existing file
If AppendData = True Then
Open fname For Append Access Write As #FNum
Else
' to create a new file overwriting if data exists already in the file
Open fname For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
' if blank
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = Chr(34) & Chr(34)
' if a number
ElseIf IsNumeric(Cells(RowNdx, ColNdx)) Then
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
' if a date
ElseIf IsDate(Cells(RowNdx, ColNdx)) Then
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
' if it is anything else
Else
CellValue = Chr(34) & Cells(RowNdx, ColNdx).Text & Chr(34)
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
' turn screen updating back on
Application.ScreenUpdating = True
Close #FNum
End Sub
Please see the attachment for the excel file :yes