サイトアイコン あきらちんの技術メモ

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

akiratin

はじめに

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

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

 

修正方法

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

元のソース

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

 

修正後のソース

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

 

モバイルバージョンを終了