VBA操作文本文件，简便代码

'代码如下
'
'===µ¥Ôª¸ñÇøÓòдÈëн¨µÄ.txt(»ò.csv/.ini)Îļþ==============
Sub ExcelToTxt(sFullName As String, rArea As Range, Optional sSeparator = ",")
Dim iOutputFileNum As Integer, iRowNum As Integer, iColNum As Integer
Dim sLine As String
Dim ArrLine() As Variant
ReDim ArrLine(1 To rArea.Columns.Count)
iOutputFileNum = FreeFile
Open sFullName For Output As #iOutputFileNum
For iRowNum = 1 To rArea.Rows.Count
For iColNum = 1 To rArea.Columns.Count
ArrLine(iColNum) = rArea.Cells(iRowNum, iColNum)
Next iColNum
sLine = Join(ArrLine, sSeparator)
If Right(sLine, 1) = sSeparator Then sLine = Left(sLine, Len(sLine) - 1)
Print #iOutputFileNum, sLine
Next iRowNum
Close #iOutputFileNum
End Sub
Sub Try_ExcelToTxt(): Call ExcelToTxt(ThisWorkbook.Path & "\" & "demo_output.txt", Selection): End Sub
'===TXTÄÚÈÝ·ÖÐÐдÈëµ¥Ôª¸ñÇøÓò==============================================================
Sub TxtToExcel(sFullName As String, Optional rFirstCell)
If IsMissing(rFirstCell) Then Set rFirstCell = ActiveCell
Dim arrA, iA As Integer
Open sFullName For Input As #1
arrA = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
Close #1
For iA = 0 To UBound(arrA): rFirstCell.Offset(iA, 0) = arrA(iA): Next iA 'rFirstCell.Resize(UBound(arrA)) = Application.WorksheetFunction.Transpose(arrA)
End Sub
Sub Try_TxtToExcel(): Call TxtToExcel(Application.GetSaveAsFilename(), [a15]): End Sub
'!!!¶ÁÈ¡TXTÎļþÈ«²¿ÄÚÈÝ,·µ»Ø×Ö·û´® !!!!!!!!!!
Function GetTxt(sFullName As String)
Open sFullName For Input As #1
GetTxt = StrConv(InputB(LOF(1), 1), vbUnicode)
'GetTxt = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)'¸ÄΪÕâ¾äÔò·µ»ØÊý×é
Close #1
End Function
Sub Try_GetTxt(): Debug.Print InStr(GetTxt(Application.GetSaveAsFilename()), vbCrLf): End Sub
'>>>>>>>¶àÐÐ×Ö·û´®Ð´ÈëTXT (µ¥ÐÐÒ²ÐÐ)>>>>>>>>
Sub StrToTxt(sString As String, sFullName As String)
Dim arrA As Variant, iA As Integer
arrA = Split(sString, vbCr)
Open sFullName For Output As #1
For iA = 0 To UBound(arrA)
Print #1, arrA(iA)
Next
Close #1
End Sub
Sub Try_StrToTxt(): Call StrToTxt("Rowx" & vbCr & "Row2", ThisWorkbook.Path & "\" & "demo_output.txt"): End Sub
'***×Ö·û´®Ìí¼Óµ½TXTÎļþĩβ*********Îļþ²»´æÔÚʱн¨Ò»¸ö***
Sub TxtAppend(sString As String, Optional sFullName)
If IsMissing(sFullName) Then sFullName = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
Dim iFileNum As Integer
iFileNum = FreeFile
Open sFullName For Append As #iFileNum
Print #iFileNum, sString
Close #iFileNum
End Sub
Sub Try_TxtAppend(): Call TxtAppend("asdf" & vbCrLf & "ertt", ThisWorkbook.Path & "\" & "xxx.txt"): End Sub
'===Ìæ»»TXTÎļþÄÚÈÝ========================================================
'---Ìæ»»TXTÎļþÖй̶¨µÄ×Ö·û´®---
Sub TxtReplace(sOldTxt As String, sNewTxt As String, Optional sFullName) ' = "C:\Users\A8-5600K\Desktop\FWP\VBA_learn\demo_output.txt")
Dim arrA As Variant, iA As Integer
If IsMissing(sFullName) Then sFullName = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt") 'ÊÖ¶¯Ñ¡TXTÎļþ
Open sFullName For Input As #1
arrA = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) 'ÒÔÊý×éÐÎʽȡµÃTXTÎļþÄÚÈÝ,ÒÔÐÐΪµ¥Î»
Close #1
Open sFullName For Output As #1
For iA = 0 To UBound(arrA) - 1
Print #1, Replace(arrA(iA), sOldTxt, sNewTxt)
Next
Close #1
End Sub
Sub Try_TxtReplace(): Call TxtReplace("RAN", "RAN2"): End Sub
'---¸ù¾ÝÇ°ºóÎÄ£¬Ìæ»»TXTÎļþÖв»¹Ì¶¨³¤¶ÈµÄ×Ö·û´®---
Sub TxtReplace2(sFullName As String, sFront As String, sBack As String, sNewString As String)
Dim sAll As String, sOld As String, sNewAll As String
Dim iStart As Integer, iLast As Integer, iA As Integer
Dim arrA As Variant
sAll = GetTxt(sFullName)
If InStr(sAll, sFront) = 0 Or InStr(sAll, sBack) = 0 Then MsgBox "Perfix or Suffix inexistence! ": Exit Sub
iStart = InStr(sAll, sFront) + Len(sFront)
iLast = InStr(sAll, sBack)
sOld = Mid(sAll, iStart, iLast - iStart)
sNewAll = Replace(sAll, sOld, sNewString) 'ÓÃReplaceº¯ÊýÒ»´Î¹ýÌ滻ȫ²¿
arrA = Split(sNewAll, vbCrLf)
Open sFullName For Output As #1
For iA = 0 To UBound(arrA) - 1
Print #1, arrA(iA)
Next
Close #1
End Sub
Sub Try_TxtReplace2(): Call TxtReplace2(ThisWorkbook.Path & "\" & "demo_output.txt", "IpAddress=", "_RTSP", "10.48.105.53"): End Sub
'---ÿNÐÐÉú³ÉÒ»¸öCSVÎļþ-------
Sub AreaSegment(rArea As Range, iFileCount As Integer)
Dim iA As Integer
For iA = 1 To rArea.Rows.Count Step iFileCount
Call ExcelToTxt(ActiveWorkbook.Path & "\" & ActiveSheet.Name & "_" & iA & "~" & iA + iFileCount & ".csv", Range(rArea.Rows(iA), rArea.Rows(iA + iFileCount - 1)))
Next iA
End Sub
Sub Try_AreaSegment(): Call AreaSegment(Range("b2:F30"), 10): End Sub
'===°ÑÎı¾ÎļþµÄÄÚÈݱä³É´úÂë--×Ö·û´®===================================================================================
Sub TxtToCode()
Dim sOrigin As String, sA As String, sNew As String
Dim arrA As Variant
Dim iA As Integer
sNew = "Function TxtToVBE()" & vbCrLf
sNew = sNew & vbTab & "Dim sAll As String" & vbCrLf
sOrigin = GetTxt(Application.GetSaveAsFilename())
sOrigin = Replace(sOrigin, """", """""")
arrA = Split(sOrigin, vbCrLf)
For iA = 0 To UBound(arrA)
sNew = sNew & vbTab & "sAll = sAll & """ & arrA(iA) & """" & " & vbCrLf & " & vbCrLf
If Right(sNew, 5) = " & " & vbCrLf Then sNew = Left(sNew, Len(sNew) - 5) & vbCrLf
Next
sNew = sNew & vbTab & "TxtToVBE = sAll" & vbCrLf
sNew = sNew & "End Function"
Debug.Print sNew
End Sub

赞一个，不错。不过里面中文乱码了

谢谢