excel - 1 MS Access 根据字段值查询多个 Excel 文件
问题描述
我有 MS Access 查询,我想根据字段值导出到多个 excel 文件 (.xlsx)。在英语中,我有一个包含我所有客户的查询,但我想为每个客户创建一个 excel 文件,以便我以后可以通过电子邮件将每个客户记录发送给他/她。
我在此链接代码中找到了一个https://www.datanumen.com/blogs/export-results-query-multiple-files-access-vba/
此代码适用于一个问题。它将文件导出为文本文件,并且由于我对 VBA 知之甚少,因此无法转换为代码以导出 excel 文件。
Sub DoExport(fieldName As String, queryName As String, filePath As String, Optional delim As Variant = vbTab)
Dim db As Database
Dim objRecordset As ADODB.Recordset
Dim qdf As QueryDef
Dim fldcounter, colno, numcols As Integer
Dim numrows, loopcount As Long
Dim data, fs, fwriter As Variant
Dim fldnames(), headerString As String
'get details of the query we'll be exporting
Set objRecordset = New ADODB.Recordset
Set db = CurrentDb
Set qdf = db.QueryDefs(queryName)
'load the query into a recordset so we can work with it
objRecordset.Open qdf.SQL, CurrentProject.Connection, adOpenDynamic, adLockReadOnly
'load the recordset into an array
data = objRecordset.GetRows
'close the recordset as we're done with it now
objRecordset.Close
'get details of the size of array, and position of the field we're checking for in that array
colno = qdf.Fields(fieldName).OrdinalPosition
numrows = UBound(data, 2)
numcols = UBound(data, 1)
'as we'll need to write out a header for each file - get the field names for that header
'and construct a header string
ReDim fldnames(numcols)
For fldcounter = 0 To qdf.Fields.Count - 1
fldnames(fldcounter) = qdf.Fields(fldcounter).Name
Next
headerString = Join(fldnames, delim)
'prepare the file scripting interface so we can create and write to our file(s)
Set fs = CreateObject("Scripting.FileSystemObject")
'loop through our array and output to the file
For loopcount = 0 To numrows
If loopcount > 0 Then
If data(colno, loopcount) <> data(colno, loopcount - 1) Then
If Not IsEmpty(fwriter) Then fwriter.Close
Set fwriter = fs.createTextfile(filePath & data(colno, loopcount) & ".txt", True)
fwriter.writeline headerString
writetoFile data, queryName, fwriter, loopcount, numcols
Else
writetoFile data, delim, fwriter, loopcount, numcols
End If
Else
Set fwriter = fs.createTextfile(filePath & data(colno, loopcount) & ".txt", True)
fwriter.writeline headerString
writetoFile data, delim, fwriter, loopcount, numcols
End If
Next
'tidy up after ourselves
fwriter.Close
Set fwriter = Nothing
Set objRecordset = Nothing
Set db = Nothing
Set qdf = Nothing
End Sub
'parameters are passed "by reference" to prevent moving potentially large objects around in memory
Sub writetoFile(ByRef data As Variant, ByVal delim As Variant, ByRef fwriter As Variant, ByVal counter As Long, ByVal numcols As Integer)
Dim loopcount As Integer
Dim outstr As String
For loopcount = 0 To numcols
outstr = outstr & data(loopcount, counter)
If loopcount < numcols Then outstr = outstr & delim
Next
fwriter.writeline outstr
End Sub
我非常感谢您的帮助和支持。谢谢!
解决方案
考虑在不同客户的记录集中循环使用 Access 的DoCmd.TransferSpreadsheet方法。无需生成文本文件、设置数组或标题循环。请务必[MyTempQuery]
提前创建查询(可以是任何内容,因为每次迭代都会覆盖其 SQL。此外,请务必转义客户名称中的任何单引号。
Dim Db As DAO.Database, qdef AS DAO.QueryDef, rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT DISTINCT [CustomerName] FROM [QueryName]")
Do While Not rst.EOF
Set qdef = db.QueryDefs("[MyTempQuery"])
qdef.SQL = "SELECT * FROM [QueryName] WHERE Customer = '" & rst!CustomerName & "'"
Set qdef = Nothing
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "MyTempQuery", _
"C:\Path\To\Excel\Files\" & rst!CustomerName & ".xlsx", True
rst.MoveNext
Loop
rst.Close
Set rst = Nothing: Set db = Nothing
推荐阅读
- sql - SQL SELECT CASE 多行 GROUP BY 一列
- php - 404 未在 LARAVEL6 中找到
- java - Spring @validated 没有级联到字段
- javascript - 让 Netlify 访问 Github 上 .gitignore 隐藏的文件
- jquery - jQuery选择中的不同元素类型
- reactjs - React useParams undefined 用于编辑用户配置文件
- python - 如何在 hitbox 中获取我的图像列表?
- c# - WPF 应用程序重启
- css - 如何在 JavaFX 中的运行时更改 primaryStage css(使用另一个类中的代码)
- ios - React Native 60 中出现无法识别的字体系列错误