更新时间:2023-01-23 09:18:54
类似的方法可能对您有用.未经测试,但可以编译...
Something like this might work for you. Untested, but compiles...
Sub CSVFile()
Const MAX_ROWS As Long = 5000
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant, newFName As String
Dim TextHeader As String, lRow As Long, lFile As Long
FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
'ListSep = Application.International(xlListSeparator)
ListSep = "^" ' Use ^ as field separator.
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
lRow = 0
lFile = 1
newFName = Replace(FName, ".csv", "_pt" & lFile & ".csv")
Open newFName For Output As #1
For Each CurrRow In SrcRg.Rows
lRow = lRow + 1
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & "~" & CurrCell.Value & "~" & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
If lRow = 1 Then TextHeader = CurrTextStr
Print #1, CurrTextStr
If lRow > MAX_ROWS Then
Close #1
lFile = lFile + 1
newFName = Replace(FName, ".csv", "_pt" & lFile & ".csv")
Open newFName For Output As #1
Print #1, TextHeader
lRow = 0
End If
Next
Close #1
End Sub