Mengeksport maklumat dari Microsoft Access sangat mudah - dengan andaian anda hanya ingin menghasilkan satu fail eksport. Tetapi apa yang anda lakukan apabila anda perlu membagi pertanyaan (atau jadual) ke dalam beberapa fail eksport? Sebagai contoh, jika anda perlu mengeksport senarai transaksi pelanggan setiap bulan - setiap pelanggan mempunyai fail eksport mereka sendiri? Di situlah artikel ini dapat membantu anda. Menghasilkan eksport sebanyak 2, 10, atau seratus eksport yang berbeza akan semudah menjalankan sedikit coretan kod VBA dan tugas akan diselesaikan dalam beberapa saat, bukan jam memotong / menampal secara manual. Oleh itu mari kita mulakan ...
Pendekatan
Oleh kerana kami mahu ini seluas dan fleksibel, kod artikel ini akan lebih lama daripada biasa, tetapi anda akan melihat mengapa tidak lama lagi.
Pertama - mari kita gariskan apa yang ingin kita capai:
Diberikan pertanyaan, keluarkan fail baru setiap kali nilai dalam bidang yang ditentukan berubah.
Cabaran
Untuk melakukan ini, kita perlu menyemak semula hasil pertanyaan, membandingkan medan yang berkaitan dalam baris semasa dengan nilai dalam baris sebelumnya – dan jika ia berbeza, buat fail baharu dan mula mengeluarkan hasil pertanyaan di sana.
Apa ini TIDAK sesuai untuk
Seperti yang telah saya nyatakan - terdapat banyak sebab mengapa anda ingin mengeksport bahagian pangkalan data anda, tetapi menggunakannya sebagai bentuk tujuan sandaran / arkib bukanlah salah satu daripadanya - pastinya tidak dengan pendekatan saya gunakan di sini - perkara terakhir yang anda mahu lakukan sekiranya anda berhadapan dengan pemulihan dari a pangkalan data mdb yang rosak sedang berusaha bagaimana menjana banyak eksport bersama-sama!
Penyelesaian?
Sentiasa ada banyak cara untuk mencari maklumat, cara ini hanyalah satu – tetapi saya rasa ia berfungsi dengan baik. Pertama sekali, kita akan membaca pertanyaan ke dalam tatasusunan untuk memudahkan pergerakan. Seterusnya, kita akan mengulang tatasusunan tersebut, menyemak sama ada kita telah menemui nilai baharu dalam medan yang berkaitan atau tidak. Jika ia bukan nilai baharu, kita akan mengeluarkan keseluruhan rekod ke fail semasa yang kita tulis, jika ia baharu, kita akan menutup fail tersebut dan memulakan yang baharu.
Dan kodnya ...
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
Apa yang dilakukan kod - perkara penting
Saya telah menambah komen pada kod di kebanyakan tempat penting, tetapi masih terdapat beberapa perkara yang perlu diserlahkan.
Pertama - kami membahagikan kod menjadi dua rutin. Yang pertama memeriksa sama ada rekod semasa harus ditulis ke fail yang sama yang sedang kita jalankan, atau sama ada rekod tersebut ditulis ke fail baru. Rutin kedua mengeluarkan butiran untuk keseluruhan rekod ke fail. Ini dilakukan dengan cara ini untuk mengurangkan pendua dalam kod, jika tidak, anda akan melihat gelung yang sama berlaku di banyak tempat.
Kedua - Saya menggunakan "Query Definition" untuk mendapatkan butiran mengenai pertanyaan yang sedang kami jalani - jika anda ingin dapat menyesuaikannya agar dapat berfungsi dengan jadual, anda akan menukarnya sehingga menggunakan " Definisi Jadual ”sebaliknya.
Dengan itu, saya cukup yakin bahawa ini adalah sedikit kod yang akan anda rujuk dan gunakan banyak!
Pengenalan Pengarang:
Mitchell Pond adalah pakar pemulihan data di DataNumen, Inc., yang merupakan pemimpin dunia dalam teknologi pemulihan data, termasuk pembaikan SQL Server data dan produk perisian pemulihan yang unggul. Untuk maklumat lebih lanjut, lawati www.datanumen.com