VBA

ACCESS VBAでEXCEL出力時の速度アップ

投稿日:

はじめに

ACCESSからEXCELへVBAを利用して出力する際にデータ量が多くなるとすごく遅くなります。

これがちょっとした修正で劇的に改善されます。

 

修正方法

名簿テンプレート.xlsxを読み込んで新しいEXCELファイル(20180901_名簿.xlsx等)を作成し、データを貼り付ける処理です。

元のソース

  • SELECT文でデータを読み込んでデータの終わりまで繰り返しデータをEXCELのセルに直接貼り付けます。
  • 貼り付け完了後、書式を設定しオートフィルタをかけて保存します。
  • 保存時には、読み出しや書き出し時のパスワードを設定できるようになっています。
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に貼り付けます。
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

 

名簿テンプレート

テンプレートはこのようなものです。

データの1件目には罫線を引いて書式を整えて(センタリング等も)おきます。

 

保存時のパスワード

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出力できますが、綺麗に出力したい場合は予めテンプレートを用意しておき、そこにデータを出力してあげると良いと思います。

 

スポンサードリンク

スポンサードリンク

-VBA
-, ,

Copyright© あきらちんの技術メモ , 2024 All Rights Reserved Powered by STINGER.