更新时间:2023-11-30 08:08:10
此范围将转换为csv.
This convert range to csv.
Sub SaveRangeToCsvFiles()
Dim FileName As String
Dim Ws As Worksheet
Dim rngDB As Range
Dim r As Long, c As Long
Dim pathOut As String
Dim i As Long
pathOut = ThisWorkbook.Path & "\" ' set your path: C:\temp\
Set Ws = ActiveSheet 'Sheets("AllData")
With Ws
r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = 2 To r
Set rngDB = .Range("a" & i).Resize(1, 6)
FileName = .Range("a" & i).Offset(, 4) & "NEW"
TransToCSV pathOut & FileName & ".csv", rngDB
Next i
End With
MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, rng As Range)
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Set objStream = CreateObject("ADODB.Stream")
vDB = rng
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile myfile, 2
.Close
End With
Set objStream = Nothing
End Sub