Yalnızca tek bir dışa aktarma dosyası oluşturmak istediğinizi varsayarsak, Microsoft Access'ten bilgi dışa aktarmak inanılmaz derecede kolaydır. Ancak bir sorguyu (veya tabloyu) birden çok dışa aktarma dosyasına bölmeniz gerektiğinde ne yaparsınız? Örneğin, her ay müşteri işlemlerinin bir listesini dışa aktarmanız gerekiyorsa - her müşterinin kendi dışa aktarma dosyası var mı? Bu makalenin size yardımcı olabileceği yer burasıdır. 2, 10 veya yüz farklı dışa aktarımlık bir dışa aktarma işlemi oluşturmak, küçük bir VBA kod parçacığını çalıştırmak kadar basit olacak ve iş, saatlerce manuel olarak kesip/yapıştırarak değil, saniyeler içinde tamamlanacak. Öyleyse başlayalım…
Yaklaşım
Bunun olabildiğince esnek ve kullanılabilir olmasını istediğimiz için, bu makalenin kodu normalden biraz daha uzun olacak, ancak nedenini birazdan anlayacaksınız.
İlk olarak – neyi başarmak istediğimizi özetleyelim:
Bir sorgu verildiğinde, belirtilen alandaki bir değer her değiştiğinde yeni bir dosya çıktısı alın.
Meydan okuma
Bunu yapabilmek için, sorgunun sonuçlarını adım adım inceleyebilmeli, mevcut satırdaki ilgili alanı önceki satırdaki değerle karşılaştırabilmeli ve eğer farklıysa yeni bir dosya oluşturup sorgu sonuçlarını oraya yazdırmaya başlamalıyız.
Bu ne için uygun DEĞİLDİR?
Daha önce de belirttiğim gibi, veritabanınızın bölümlerini dışa aktarmak istemenizin pek çok nedeni vardır, ancak bunu bir yedekleme/arşivleme biçimi olarak kullanmak bunlardan biri değildir – kesinlikle benim yaklaşımımla değil Burada kullanmak – bir hastalıktan kurtulmakla karşı karşıya kalırsanız, yapmak isteyeceğiniz son şey. bozuk mdb veritabanı çok sayıda ihracatı nasıl bir araya getireceğini düşünüyor!
Çözüm?
Bir işi yapmanın her zaman birçok yolu vardır, bu sadece bir tanesi – ama bence oldukça iyi çalışan bir yol. Öncelikle, gezinmeyi kolaylaştırmak için sorguyu bir diziye okuyacağız. Ardından, ilgili alanda yeni bir değer bulup bulmadığımızı kontrol etmek için bu diziyi döngüye alacağız. Yeni bir değer değilse, tüm kaydı şu anda yazdığımız dosyaya yazdıracağız; yeni bir değer ise, dosyayı kapatıp yeni bir dosya başlatacağız.
Ve 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
Kod ne yapıyor – önemli noktalar
Kodun en önemli yerlerine açıklamalar ekledim, ancak yine de vurgulanması gereken birkaç nokta var.
İlk olarak – kodu iki rutine ayırdık. İlki, geçerli kaydın şu anda üzerinde çalıştığımız dosyaya mı yoksa yeni bir dosyaya mı yazılması gerektiğini kontrol eder. İkinci rutin, tüm kaydın ayrıntılarını dosyaya verir. Kodda yinelemeyi azaltmak için bu şekilde yapılmıştır, aksi takdirde birçok yerde aynı döngünün gerçekleştiğini görürsünüz.
İkincisi – Üzerinde çalıştığımız sorguyla ilgili ayrıntıları almak için “Sorgu Tanımı”nı kullanıyorum – bunu tablolarla çalışacak şekilde uyarlamak istiyorsanız, bunu “ Tablo Tanımı”.
Bununla birlikte, bunun geri başvuracağınız ve çokça kullanacağınız bir kod parçası olduğundan oldukça eminim!
Yazar Tanıtımı:
Mitchell Pond, bir veri kurtarma uzmanıdır. DataNumendahil olmak üzere veri kurtarma teknolojilerinde dünya lideri olan , Inc. onarım SQL Server veri ve excel kurtarma yazılımı ürünleri. Daha fazla bilgi için ziyaret edin www.datanumen.com