''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
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 = Chr(34) & Chr(34)
Else
CellValue = Cells(RowNdx, ColNdx).Text
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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Because the ExportToTextFile procedure accepts input parameters, you must call it from other VBA code, such as the following: Sub DoTheExport()
ExportToTextFile FName:="C:\Test.txt", Sep:=";", _
SelectionOnly:=False, AppendData:=True
End Sub
In the example DoTheExport procedure above, the file name and the separator character are hard coded in to the code. If you want to prompt the user for the file name and the separator character, use code like the following:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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 = Application.InputBox("Enter a separator character.", Type:=2)
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Separator: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=True
End Sub
Sub ExcelToTxt()
Dim MyPath As String
MyPath = "D:\"
MyFileName = InputBox("Nhap ten file can luu:", "Export from excel to text")
ActiveSheet.Select
ActiveSheet.Copy
ActiveWorkbook.SaveAs _
Filename:=MyPath & MyFileName & ".txt", _
FileFormat:=xlUnicodeText, CreateBackup:=False
ActiveWorkbook.Close True
End Sub
Sub ExcelToTxt()
Dim MyPath As String, MyFileName As String
Dim newbook As Workbook
MyPath = "D:\"
MyFileName = InputBox("Nhap ten file can luu:", "Export from excel to text")
Selection.Copy
Set newbook = Workbooks.Add
With newbook
.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
.SaveAs Filename:=MyPath & MyFileName & ".txt", _
FileFormat:=xlUnicodeText, CreateBackup:=False
.Close True
End With
End Sub
)
Sub ExcelToTxt()
Dim MyPath As String, MyFileName As String
Dim newbook As Workbook
MyPath = "D:\"
MyFileName = InputBox("Nhap ten file can luu:", "Export from excel to text")
Selection.Copy
Set newbook = Workbooks.Add
With newbook
.Sheets("Sheet1").Range("B1:C22").PasteSpecial xlPasteValues
.SaveAs Filename:=MyPath & MyFileName & ".txt", _
FileFormat:=xlUnicodeText, CreateBackup:=False
.Close True
End With
End SubMình muốn xuất vùng B1:C22 thành text và đã sửa lại của bạn như sau : (tuy nhiên vẫn không được bạn ơi, nó xuất ra 1 file text trắng
Bạn ktra giúp mình với , mình không rành VB lắm, cảm ơn bạn nhiều .PHP:Sub ExcelToTxt() Dim MyPath As String, MyFileName As String Dim newbook As Workbook MyPath = "D:\" MyFileName = InputBox("Nhap ten file can luu:", "Export from excel to text") Selection.Copy Set newbook = Workbooks.Add With newbook .Sheets("Sheet1").Range("B1:C22").PasteSpecial xlPasteValues .SaveAs Filename:=MyPath & MyFileName & ".txt", _ FileFormat:=xlUnicodeText, CreateBackup:=False .Close True End With End Sub
Sub ExcelToTxt()
Dim MyPath As String, MyFileName As String
Dim NewBook As Workbook
MyPath = "D:\"
MyFileName = InputBox("Nhap ten file can luu:", "Export from excel to text")
ActiveSheet.[B1:C22].Select ''Thêm đoạn này vô là xong
Selection.Copy
Set NewBook = Workbooks.Add
With NewBook
.Sheets("Sheet1").[A1].PasteSpecial xlPasteValues ''Sửa tí chỗ này nữa
.SaveAs Filename:=MyPath & MyFileName & ".txt", _
FileFormat:=xlUnicodeText, CreateBackup:=False
.Close True
End With
End Sub
Được mà bạn
Sub Data2txtFile()
Dim txtFile As String, sArray, tmp(), Arr(), lR As Long, lC As Long
sArray = Selection.Value
txtFile = ThisWorkbook.Path & "\tmp.txt"
ReDim tmp(1 To UBound(sArray, 2))
ReDim Arr(1 To UBound(sArray, 1))
With CreateObject("Scripting.FileSystemObject")
With .CreateTextFile(txtFile, True, True)
For lR = 1 To UBound(sArray, 1)
For lC = 1 To UBound(sArray, 2)
tmp(lC) = sArray(lR, lC)
Next
Arr(lR) = Join(tmp, vbTab)
Next
.Write Join(Arr, vbCrLf)
.Close
End With
End With
End Sub
