はじめに
ACCESSからEXCELへVBAを利用して出力する際にデータ量が多くなるとすごく遅くなります。
これがちょっとした修正で劇的に改善されます。
修正方法
名簿テンプレート.xlsxを読み込んで新しいEXCELファイル（20180901_名簿.xlsx等）を作成し、データを貼り付ける処理です。
元のソース
- SELECT文でデータを読み込んでデータの終わりまで繰り返しデータをEXCELのセルに直接貼り付けます。
- 貼り付け完了後、書式を設定しオートフィルタをかけて保存します。
- 保存時には、読み出しや書き出し時のパスワードを設定できるようになっています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Private Sub EXCEL_Click() On Error GoTo Err_Handler Dim CN As ADODB.Connection Dim RS As ADODB.Recordset Dim strSQL As String Dim objExcel As Object Dim fileName As String Dim newFileName As String Dim intRow As Integer Dim recCnt As Integer Screen.MousePointer = 11 Set CN = CurrentProject.Connection Set RS = New ADODB.Recordset ' CreateSQL() ： SELECT文を生成するオリジナルの関数です。 strSQL = CreateSQL() RS.Open strSQL, CN, adOpenStatic, adLockReadOnly recCnt = RS.RecordCount ' テンプレートファイル名 fileName = Application.CurrentProject.Path & "\名簿テンプレート.xlsx" newFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, "yyyyMMdd") & "_名簿.xlsx" ' Excelオブジェクトを生成 Set objExcel = CreateObject("Excel.Application") With objExcel ' 画面の再描画を抑止 .ScreenUpdating = False .displayalerts = False ' ブックを開く .workbooks.Open fileName .workbooks(1).saveas (newFileName) ' 各レコードをExcelに出力 intRow = 2 Do Until RS.EOF .cells(intRow, 1).Value = RS!氏名 .cells(intRow, 2).Value = RS!フリガナ .cells(intRow, 3).Value = RS!性別 .cells(intRow, 4).Value = RS!生年月日 .cells(intRow, 5).Value = RS!郵便番号 .cells(intRow, 6).Value = RS!都道府県 .cells(intRow, 7).Value = RS!住所 .cells(intRow, 8).Value = RS!電話番号 .cells(intRow, 9).Value = RS!携帯番号 .cells(intRow, 10).Value = RS!メールアドレス intRow = intRow + 1 RS.MoveNext Loop ' 書式設定 .Range("A2:J2").Select .Selection.Copy .Range("A3:J" & intRow - 1).Select .Selection.PasteSpecial Paste:=&HFFFFEFE6, Operation:=&HFFFFEFD2, SkipBlanks:=False, Transpose:=False ' 最下段罫線 .Range("A" & intRow - 1 & ":J" & intRow - 1).Borders(9).LineStyle = 1 .Range("A" & intRow - 1 & ":J" & intRow - 1).Borders(9).Weight = -4138 ' 幅自動調整 .Columns("A:J").AutoFit ' オートフィルター .Range("A1:J1").Select .Selection.AutoFilter RS.Close Set RS = Nothing CN.Close Set CN = Nothing ' A1セルだけを選択状態にする .Range("A1").Select ' 保存 If Me.readOnly.Value = -1 Then .workbooks(1).ReadOnlyRecommended = True Else .workbooks(1).ReadOnlyRecommended = False End If .workbooks(1).WritePassword = IIf(IsNull(Me.writePass.Value), "", Me.writePass) .workbooks(1).saveas fileName:=newFileName, Password:=IIf(IsNull(Me.readPass.Value), "", Me.readPass.Value) 'Excel終了 .Quit End With Set objExcel = Nothing MsgBox "Excel出力は、正常に完了しました。", vbInformation Exit_Handler: 'オブジェクトの廃棄処理 If Not (objExcel Is Nothing) Then 'Excelが閉じていなかったら閉じて終了 objExcel.Quit Set objExcel = Nothing End If If Not (RS Is Nothing) Then RS.Close Set RS = Nothing End If If Not (CN Is Nothing) Then CN.Close Set CN = Nothing End If Screen.MousePointer = 0 Exit Sub Err_Handler: MsgBox Err.Description Resume Exit_Handler |
修正後のソース
- SELECT文でデータを読み込んでデータの終わりまで繰り返しデータを cellData配列に格納します。
- すべてのデータが格納されたcellDataをRangeを使ってまとめてEXCELに貼り付けます。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
Private Sub EXCEL_Click() On Error GoTo Err_Handler Dim CN As ADODB.Connection Dim RS As ADODB.Recordset Dim strSQL As String Dim objExcel As Object Dim fileName As String Dim newFileName As String Dim intRow As Integer Dim cellData() As Variant Dim recCnt As Integer Screen.MousePointer = 11 Set CN = CurrentProject.Connection Set RS = New ADODB.Recordset ' CreateSQL() ： SELECT文を生成するオリジナルの関数です。 strSQL = CreateSQL() RS.Open strSQL, CN, adOpenStatic, adLockReadOnly recCnt = RS.RecordCount ' テンプレートファイル名 fileName = Application.CurrentProject.Path & "\名簿テンプレート.xlsx" newFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, "yyyyMMdd") & "_名簿.xlsx" ReDim cellData(recCnt - 1, 10) ' Excelオブジェクトを生成 Set objExcel = CreateObject("Excel.Application") With objExcel ' 画面の再描画を抑止 .ScreenUpdating = False .displayalerts = False ' ブックを開く .workbooks.Open fileName .workbooks(1).saveas (newFileName) ' 各レコードをExcelに出力 intRow = 2 Do Until RS.EOF ' .cells(intRow, 1).Value = RS!氏名 ' .cells(intRow, 2).Value = RS!フリガナ ' .cells(intRow, 3).Value = RS!性別 ' .cells(intRow, 4).Value = RS!生年月日 ' .cells(intRow, 5).Value = RS!郵便番号 ' .cells(intRow, 6).Value = RS!都道府県 ' .cells(intRow, 7).Value = RS!住所 ' .cells(intRow, 8).Value = RS!電話番号 ' .cells(intRow, 9).Value = RS!携帯番号 ' .cells(intRow, 10).Value = RS!メールアドレス cellData(intRow - 2, 0) = RS!氏名 cellData(intRow - 2, 1) = RS!フリガナ cellData(intRow - 2, 2) = RS!性別 cellData(intRow - 2, 3) = RS!生年月日 cellData(intRow - 2, 4) = RS!郵便番号 cellData(intRow - 2, 5) = RS!都道府県 cellData(intRow - 2, 6) = RS!住所 cellData(intRow - 2, 7) = RS!電話番号 cellData(intRow - 2, 8) = RS!携帯番号 cellData(intRow - 2, 9) = RS!メールアドレス intRow = intRow + 1 RS.MoveNext Loop .Range(.cells(2, 1), .cells(recCnt + 1, 10)) = cellData ' 書式設定 .Range("A2:J2").Select .Selection.Copy .Range("A3:J" & intRow - 1).Select .Selection.PasteSpecial Paste:=&HFFFFEFE6, Operation:=&HFFFFEFD2, SkipBlanks:=False, Transpose:=False ' 最下段罫線 .Range("A" & intRow - 1 & ":J" & intRow - 1).Borders(9).LineStyle = 1 .Range("A" & intRow - 1 & ":J" & intRow - 1).Borders(9).Weight = -4138 ' 幅自動調整 .Columns("A:J").AutoFit ' オートフィルター .Range("A1:J1").Select .Selection.AutoFilter RS.Close Set RS = Nothing CN.Close Set CN = Nothing ' A1セルだけを選択状態にする .Range("A1").Select ' 保存 If Me.readOnly.Value = -1 Then .workbooks(1).ReadOnlyRecommended = True Else .workbooks(1).ReadOnlyRecommended = False End If .workbooks(1).WritePassword = IIf(IsNull(Me.writePass.Value), "", Me.writePass) .workbooks(1).saveas fileName:=newFileName, Password:=IIf(IsNull(Me.readPass.Value), "", Me.readPass.Value) 'Excel終了 .Quit End With Set objExcel = Nothing MsgBox "Excel出力は、正常に完了しました。", vbInformation Exit_Handler: 'オブジェクトの廃棄処理 If Not (objExcel Is Nothing) Then 'Excelが閉じていなかったら閉じて終了 objExcel.Quit Set objExcel = Nothing End If If Not (RS Is Nothing) Then RS.Close Set RS = Nothing End If If Not (CN Is Nothing) Then CN.Close Set CN = Nothing End If Screen.MousePointer = 0 Exit Sub Err_Handler: MsgBox Err.Description Resume Exit_Handler |
名簿テンプレート
テンプレートはこのようなものです。
データの１件目には罫線を引いて書式を整えて（センタリング等も）おきます。
保存時のパスワード
ACCESSのフォームに以下の様な項目を用意して対応します。
読み取り専用を推奨する
チェックが付いている場合は、ReadOnlyRecommended をTrueをセットします。
If Me.readOnly.Value = -1 Then
.workbooks(1).ReadOnlyRecommended = True
Else
.workbooks(1).ReadOnlyRecommended = False
End If
書き込みパスワード
フォームの書き込みパスワードに文字が入力されている場合は、WritePassword にその文字をセットします。
.workbooks(1).WritePassword = IIf(IsNull(Me.writePass.Value), "", Me.writePass)
読み取りパスワード
フォームの読み取りパスワードに文字が入力されている場合は、保存時のPasswordオプションでその文字を設定します。
.workbooks(1).saveas fileName:=newFileName, Password:=IIf(IsNull(Me.readPass.Value), "", Me.readPass.Value)
最後に
ACCESSで用意されているエクスポート操作は非常に簡単にEXCEL出力できますが、綺麗に出力したい場合は予めテンプレートを用意しておき、そこにデータを出力してあげると良いと思います。