Microsoft Access-dən məlumat ixrac etmək olduqca asandır – yalnız bir ixrac faylı yaratmaq istədiyinizi fərz etsək. Bəs bir sorğunu (və ya cədvəli) çoxsaylı ixrac fayllarına bölmək lazım olduqda nə edirsiniz? Məsələn, hər ay müştəri əməliyyatlarının siyahısını ixrac etməlisinizsə - hər bir müştərinin öz ixrac faylı varmı? Məhz burada bu məqalə sizə kömək edə bilər. 2, 10 və ya yüz müxtəlif ixracın ixracı bir az VBA kod parçasını işə salmaq qədər sadə olacaq və iş saatlarla əl ilə kəsmək/yapışdırmaqla deyil, saniyələr ərzində tamamlanacaq. Elə isə başlayaq…
Yanaşma
Bunun mümkün qədər çevik və istifadəyə yararlı olmasını istədiyimiz üçün bu məqalənin kodu həmişəkindən bir qədər uzun olacaq, lakin bunun səbəbini tezliklə görəcəksiniz.
Əvvəlcə nəyə nail olmaq istədiyimizi qeyd edək:
Sorğunu nəzərə alaraq, müəyyən bir sahədə dəyər hər dəfə dəyişdikdə yeni fayl çıxarın.
Müsabiqə
Bunu etmək üçün, sorğunun nəticələrini mərhələli şəkildə nəzərdən keçirməli, cari sətirdəki müvafiq sahəni əvvəlki sətirdəki dəyərlə müqayisə etməliyik və əgər onlar fərqlidirsə, yeni bir fayl yaratmalı və sorğu nəticələrini orada göstərməyə başlamalıyıq.
Bu nə üçün uyğun deyil
Artıq qeyd etdiyim kimi – verilənlər bazanızın hissələrini ixrac etmək istəməyiniz üçün çoxlu səbəblər var, lakin ondan ehtiyat nüsxə/arxiv məqsədləri kimi istifadə etmək onlardan biri deyil – əlbəttə ki, mənim yanaşmamla deyil. burada istifadə etmək – a. sağalma ilə üzləşdiyiniz təqdirdə etmək istədiyiniz son şey zədələnmiş mdb verilənlər bazası çoxlu ixracatı necə birləşdirmək üzərində işləyir!
Həll?
Pişik dərisini soymağın həmişə bir çox yolu var, bu üsul yalnız biridir - amma düşünürəm ki, olduqca yaxşı işləyən biridir. Əvvəlcə axtarışı asanlaşdırmaq üçün massivə oxuyacağıq. Daha sonra həmin massivdən dövrə vuraraq müvafiq sahədə yeni bir dəyər tapıb tapmadığımızı yoxlayacağıq. Əgər bu yeni bir dəyər deyilsə, bütün qeydi yazdığımız cari fayla çıxaracağıq, əgər yenidirsə, həmin faylı bağlayacağıq və yenisini başladacağıq.
Və kod…
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
Kodun nə etdiyi – əsas məqamlar
Kodun əksər əsas yerlərində şərhlər əlavə etdim, amma yenə də vurğulamağa dəyər bir neçə şey var.
Birincisi - kodu iki rejimə böldük. Birincisi, cari qeydin hazırda üzərində işlədiyimiz eyni fayla yazılmalı və ya yeni fayla yazılmalı olub-olmadığını yoxlayır. İkinci rejim bütün qeydin təfərrüatlarını fayla çıxarır. Bu, kodda təkrarlanmanı azaltmaq üçün belə edilib, əks halda bir çox yerdə eyni döngələrin baş verdiyini görərsiniz.
İkincisi – qarşı işlədiyimiz sorğu haqqında təfərrüatları əldə etmək üçün “Sorğu Tərifindən” istifadə edirəm – əgər siz bunu cədvəllərlə işləmək üçün uyğunlaşdırmaq istəyirsinizsə, onu dəyişdirməyə baxardınız ki, o “ Cədvəl tərifi” əvəzinə.
Bununla belə, əminəm ki, bu, çox istifadə edəcəyiniz bir az koddur!
Müəllif Giriş:
Mitchell Pond məlumatların bərpası üzrə mütəxəssisdir DataNumendaxil olmaqla məlumatların bərpası texnologiyaları üzrə dünya lideri olan , Inc təmir SQL Server məlumat və excel bərpa proqram məhsulları. Ətraflı məlumat üçün ziyarət edin www.datanumen.com