转换为csv之前如何保存Excel记录

Question

我有VBA宏(GetData)从sql中获取记录，将其放在工作表中，然后调用另一个宏(ConvertToCsv)将工作表转换为csv格式。

如果我运行转换宏，在GetData宏之后，没有问题。

当我调用Convert宏时，在GetData宏中csv文件缺少一些记录。

get records macro

Sub getData()
.
.
comm.CommandText = _
"SELECT x, y, z FROM A"
rec.Open comm

If rec.EOF = True Then 'Check if there is any records
MsgBox ("There is no records")
Exit Sub
End If

row = 1
col = 1
Do While Not rec.EOF
WirteRecordsToSheets rec row col
col = 1
row = row + 1
rec.MoveNext
Loop
ActiveWorkBook.save
call ConvertToCsv
End Sub

Sub ConvertToCsv()
fRow = 1
fCol = 1
lCol = 20
filePath = "C:aaabbb"
fileName = "file.csv"
MakeDirectory filePath
Worksheets("1").Select
Set rng = Range(Cells(fRow, fCol), Cells(lRow, lCol))
rng.Value = Application.Trim(rng)

Set cpFromWB = ActiveWorkbook
' Set range to copy
With cpFromWB
'set the selected range
Set cpFromRng = Range(Cells(fRow, fCol), Cells(lRow, lCol))
End With
' Create new workbook
Set cpToWB = Workbooks.Add
Set cpToRng = cpToWB.ActiveSheet.Range("A1")
'Copy everything over to the new workbook
cpFromRng.Copy Destination:=cpToRng
' Save as CSV-file
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fileName:=filePath & fileName, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
MsgBox ("the csv file named: " & fileName & " has successfully saved in the path: " & filePath)
End Sub

WirteRecordsToSheets(rec As Recordset, ByVal xlCol As Integer, ByVal xlRow As Integer)
Worksheets("1").Select

Cells(xlRow, xlCol).NumberFormat = "@"
Cells(xlRow, xlCol).Value = Trim(rec("x"))

xlCol = xlCol + 1 
Cells(xlRow, xlCol).NumberFormat = "@"
Cells(xlRow, xlCol).Value = Trim(rec("y"))
xlCol = xlCol + 1 
Cells(xlRow, xlCol).NumberFormat = "@"
Cells(xlRow, xlCol).Value = Trim(rec("z"))
End Sub

Answer 1

使用CopyFromRecordset方法

Option Explicit
Sub getData()
Dim conn As ADODB.Connection, rec As ADODB.Recordset
Dim wb As Workbook, ws As Worksheet

Const FOLDER = "C:tempbbb"
Const CSVNAME = "file.csv"

' connect to db
Set conn = connectdb("test.accdb")

' get records from db
Set rec = conn.Execute("SELECT TRIM(x),TRIM(y),TRIM(z) FROM A")

If rec.EOF = True Then 'Check if any records
MsgBox ("There are no records")
Exit Sub
Else

MakeDirectory FOLDER
' copy records to new workbook
Set wb = Workbooks.Add
Set ws = wb.Sheets(1)
With ws
.Range("A:C").NumberFormat = "@"
.Range("A1").CopyFromRecordset rec
' save as csv
Application.DisplayAlerts = False
.SaveAs filename:=FOLDER & CSVNAME, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
End With

wb.Close savechanges:=False
MsgBox ("the csv file named: " & CSVNAME & _
" has successfully saved in the path: " & FOLDER), vbInformation

End If
conn.Close
End Sub
Sub MakeDirectory(s)
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(s) Then fso.createFolder s
End Sub
Function connectdb(s As String) As ADODB.Connection
Set connectdb = New ADODB.Connection
connectdb.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & s
End Function