فصل ۳۵ — استفاده از Excel برای خروجی

Automate کردن Spreadsheetهای Excel با VBA برای خروجی داده از Access بسیار کاربردی است. Reportهای Access برای ارائهٔ Tabular خوب‌اند، اما Copy/Paste به Applicationهای دیگر دشوار است و گاهی User قالب سفارشی‌ای می‌خواهد که Access Report پشتیبانی نمی‌کند. این فصل از Northwind برای Sample Data استفاده می‌کند.

استفاده از Recordset برای ساخت Spreadsheet

در VBE Module جدید بسازید و Reference به Microsoft Excel 14.0 Object Library اضافه کنید.

Sub CreateSpreadsheet()
Dim RecSet As Recordset
Dim MyExcel As Excel.Application
Dim MyBook As Workbook
Dim MySheet As Worksheet
Set MyExcel = CreateObject("Excel.Application")
Set MyBook = MyExcel.Workbooks.Add
Set MySheet = MyBook.Worksheets(1)
Set RecSet = CurrentDb.OpenRecordset("customers")
MySheet.Range("a1").CopyFromRecordset RecSet
MyBook.SaveAs ("TestExcel")
MyBook.Close
MyExcel.Quit
Set RecSet = Nothing
Set MyExcel = Nothing
Set MyBook = Nothing
Set MySheet = Nothing
End Sub

Excel Object و Workbook خالی ساخته می‌شود، Recordset از Customers باز و از A1 به Sheet اول Copy می‌شود؛ سپس Workbook ذخیره و Excel بسته می‌شود. انتقال ممکن است چند ثانیه طول بکشد. نتیجه شبیه Copy/Paste دادهٔ Access است، اما Column Heading ندارد و Width ستون‌ها لزوماً مناسب نیست.

استفاده از Spreadsheet موجود به‌عنوان Template

برای خروجی مرتب‌تر، Workbookای با Heading و Width درست اما بدون Data بسازید. یک ردیف Customers را از Access به Excel به‌صورت Text Paste کنید، Widthها را تنظیم و Data Row را حذف کنید؛ Template را MyRecSet ذخیره و ببندید.

Sub CreateSpreadsheet1()
Dim RecSet As Recordset
Dim MyExcel As Excel.Application
Dim MyBook As Workbook
Dim MySheet As Worksheet
Set MyExcel = CreateObject("Excel.Application")
Set MyBook = MyExcel.Workbooks.Open("MyRecSet", , True)
Set MySheet = MyBook.Worksheets(1)
Set RecSet = CurrentDb.OpenRecordset("customers")
MySheet.Range("a2").CopyFromRecordset RecSet
On Error Resume Next
Kill "TestExcel.xlsx"
On Error GoTo 0
MyBook.SaveAs ("TestExcel")
MyBook.Close
MyExcel.Quit
Set RecSet = Nothing
Set MyExcel = Nothing
Set MyBook = Nothing
Set MySheet = Nothing
End Sub

Template به‌صورت Read-only باز می‌شود و Data از A2 قرار می‌گیرد تا Headingها حفظ شوند. Kill نسخهٔ قبلی TestExcel را حذف می‌کند. خروجی برای User خواناتر است و حتی می‌توان Pivot Table را از قبل در Template گنجاند.

انتقال Numberهای منفرد به Excel

وقتی داده نباید در یک Chunk پیوسته کپی شود، Recordset را رکوردبه‌رکورد پیمایش کنید:

Sub CreateSpreadsheet2()
Dim RecSet As Recordset
Dim MyExcel As Excel.Application
Dim MyBook As Workbook
Dim MySheet As Worksheet
Dim strTemp As String
Dim Coun As Long
Dim Coun1 As Long
Set MyExcel = CreateObject("Excel.Application")
Set MyBook = MyExcel.Workbooks.Add
Set MySheet = MyBook.Worksheets(1)
strTemp = "SELECT Products.[Product Name], Sum([Unit Cost]*[quantity]) AS Cost "
strTemp = strTemp & "FROM Products INNER JOIN [Purchase Order Details] "
strTemp = strTemp & "ON Products.ID = [Purchase Order Details].[Product ID] "
strTemp = strTemp & "GROUP BY Products.[Product Name];"
Set RecSet = CurrentDb.OpenRecordset(strTemp)
Do Until RecSet.EOF
Coun = Coun + 1
MySheet.Range("a" & Coun).Value = RecSet![Product Name]
MySheet.Range("b" & Coun).Value = RecSet!Cost
Coun1 = Coun1 + 1
If Coun1 = 5 Then
Coun = Coun + 2
Coun1 = 0
End If
RecSet.MoveNext
Loop
On Error Resume Next
Kill "TestExcel.xlsx"
On Error GoTo 0
MyBook.SaveAs ("TestExcel")
MyBook.Close
MyExcel.Quit
Set RecSet = Nothing
Set MyExcel = Nothing
Set MyBook = Nothing
Set MySheet = Nothing
End Sub

SQL در چند String ساخته شده تا خواناتر بماند. Product Name و Total Cost در ستون‌های A و B قرار می‌گیرند. Counter دوم پس از هر پنج Item دو ردیف فاصله ایجاد می‌کند؛ کاری که با CopyFromRecordset قابل انجام نبود.

اجازه دادن به کاربران برای طراحی Excel Report خودشان

User می‌تواند در Template محل Numberها را تعیین کند. در مثال، در Cellِ C5 عبارت !Northwind Traders Syrup نوشته می‌شود. علامت ! Marker است تا VBA بداند باید برای این Product عدد پیدا کند.

Sub CreateSpreadsheet3()
Dim RecSet As Recordset
Dim MyExcel As Excel.Application
Dim MyBook As Workbook
Dim MySheet As Worksheet
Dim strTemp As String
Dim strCriteria As String
Set MyExcel = CreateObject("Excel.Application")
Set MyBook = MyExcel.Workbooks.Open("MyRecSet", , True)
Set MySheet = MyBook.Worksheets(1)
For n = 1 To 20
For m = 1 To 20
strCriteria = MySheet.Range(Chr(n + 64) & m).Value
If Left(strCriteria, 1) = "!" Then
On Error Resume Next
strCriteria = Mid(strCriteria, 2)
strTemp = "SELECT Products.[Product Name], Sum([Unit Cost]*[quantity]) AS Cost "
strTemp = strTemp & "FROM Products INNER JOIN [Purchase Order Details] "
strTemp = strTemp & "ON Products.ID = [Purchase Order Details].[Product ID] "
strTemp = strTemp & "WHERE [Product Name]='" & strCriteria & "' "
strTemp = strTemp & "GROUP BY Products.[Product Name];"
Set RecSet = CurrentDb.OpenRecordset(strTemp)
If RecSet.RecordCount > 0 Then
MySheet.Range(Chr(n + 64) & m).Value = RecSet!cost
Else
MySheet.Range(Chr(n + 64) & m).Value = 0
End If
End If
Next m
Next n
On Error Resume Next
Kill "TestExcel.xlsx"
On Error GoTo 0
MyBook.SaveAs ("TestExcel")
MyBook.Close
MyExcel.Quit
Set RecSet = Nothing
Set MyExcel = Nothing
Set MyBook = Nothing
Set MySheet = Nothing
End Sub

کد Range بیست‌در‌بیست از A1 را می‌گردد. هر Cell که String آن با ! شروع شود شناسایی، Marker حذف و Criteria به WHERE افزوده می‌شود؛ مقدار به همان Cell برگردانده می‌شود و اگر رکوردی نبود 0 نوشته می‌شود. On Error برای ورودی‌های مشکل‌دار User به کار رفته است. فایل با نام دیگری ذخیره می‌شود تا Criteriaهای Template اصلی باقی بمانند.

User می‌تواند Criteria مرکب نیز بنویسد؛ مثال منبع: ![Product Name]= ‘Northwind Traders Syrup’ and [Reorder Level]>10. تا وقتی عبارت بتواند به SQL داخل VBA Concatenate شود، روش کار می‌کند.

صفحهٔ پایانی این بخش در نسخهٔ اصلی عمداً خالی است.