Export informací z aplikace Microsoft Access je neuvěřitelně snadný - za předpokladu, že chcete vytvořit pouze jeden exportní soubor. Co ale dělat, když potřebujete rozdělit dotaz (nebo tabulku) na více exportních souborů? Například pokud potřebujete každý měsíc exportovat seznam zákaznických transakcí - každý zákazník má svůj vlastní exportní soubor? Tam vám může tento článek pomoci. Produkce exportu 2, 10 nebo stovky různých exportů bude stejně jednoduchá jako spuštění malého fragmentu kódu VBA a úloha bude hotová za několik sekund, ne za hodiny ručního vyjmutí / vložení. Tak pojďme začít ...
Přístup
Protože chceme, aby to bylo co nejvíce flexibilní a použitelné, bude kód tohoto článku o něco delší než obvykle, ale brzy uvidíte proč.
Za prvé - nastíníme, čeho chceme dosáhnout:
Vzhledem k dotazu odešle nový soubor pokaždé, když se změní hodnota v zadaném poli.
Výzva
Abychom to mohli udělat, musíme být schopni procházet výsledky dotazu a porovnávat příslušné pole v aktuálním řádku s hodnotou v předchozím řádku – a pokud se liší, vytvořit nový soubor a začít tam vypisovat výsledky dotazu.
K čemu to NENÍ vhodné
Jak jsem již zmínil - existuje spousta důvodů, proč byste chtěli exportovat části vaší databáze, ale její použití jako forma zálohování / archivace není jedním z nich - rozhodně ne s přístupem, který jsem pomocí zde - poslední věc, kterou chcete udělat, pokud se setkáte s zotavením z poškozená databáze mdb pracuje na tom, jak spojit spoustu exportů dohromady!
Řešení?
Vždy existuje spousta způsobů, jak stáhnout kočku z kůže, tento způsob je jen jeden – ale myslím, že funguje docela dobře. Nejprve načteme dotaz do pole, abychom se v něm snadněji pohybovali. Dále projdeme toto pole smyčkou a zkontrolujeme, zda jsme v příslušném poli našli novou hodnotu, či nikoli. Pokud se nejedná o novou hodnotu, vypíšeme celý záznam do aktuálního souboru, do kterého zapisujeme, pokud ano, zavřeme tento soubor a začneme nový.
A kód ...
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
Co kód dělá - klíčové body
Do kódu jsem přidal komentáře na většině klíčových míst, ale stále je tu pár věcí, které stojí za zdůraznění.
Za prvé - rozdělili jsme kód do dvou rutin. První zkontroluje, zda by měl být aktuální záznam zapsán do stejného souboru, na kterém právě pracujeme, nebo zda má být zapsán do nového souboru. Druhá rutina odešle do souboru podrobnosti celého záznamu. Bylo to provedeno tímto způsobem, aby se omezila duplikace v kódu, jinak byste viděli stejné opakování na mnoha místech.
Zadruhé - používám „Definici dotazu“ k získání podrobností o dotazu, proti kterému pracujeme - pokud chcete mít možnost toto přizpůsobit pro práci s tabulkami, podíváte se na jejich výměnu tak, aby to Definice tabulky “.
Díky tomu jsem si docela jistý, že se jedná o trochu kódu, na který se budete vracet a hodně ho používat!
Úvod autora:
Mitchell Pond je expert na obnovu dat v DataNumen, Inc., která je světovým lídrem v oblasti technologií pro obnovu dat, včetně opravit SQL Server datum a excelové softwarové produkty pro obnovu. Pro více informací navštivte www.datanumen.com