エクセルへデータをコピーし表示するサンプル(VB6)

＜このサンプルの概要＞
２次元配列形式のデータをそのままエクセルシートにコピーして表示します。コピーされ
る各行はＶＢの１次元配列で、それらをCollectionオブジェクトとして集めて、このモジ
ュールに引数渡しします。Collectionオブジェクトを使用し、一気にコピーする事で１セ
ルずつコピーをするより何倍（何十倍？）も処理が早くなります。プログラムからエクセ
ルにデータ出力する際の重要な事は出来るだけまとめてコピーする事だと思います。

Private Sub Command1_Click()
    Dim cl As New Collection
    Dim da(255) As Variant
    Dim r As Long
    Dim c As Long

    For r = 1 To 100
        For c = 1 To UBound(da) + 1
            da(c - 1) = "" & r & " " & c
        Next c
        cl.Add da
    Next r

    SetDataToExcel Me, cl
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnloadExcel
    End
End Sub

'**********************************************************************
' 機能名    : modDataToExcel.bas
' 機能説明  : エクセルへデータコピーし表示する
'**********************************************************************
Private Const CPMAXROW = 10     ' 一括コピー行数
Private oXlsApp As Object       ' Excel.Application
Private oSheet As Object        ' Excel.Worksheet
Private oRange As Object        ' Excel.Range

' 関数名    : SetDataToExcel
' 引き数    : myForm(i) : 親フォーム
'           : cl    (i) : データコレクション
' 機能説明  : エクセルへのデータコピー＆エクセル表示
Public Sub SetDataToExcel(ByVal myForm As Form, ByVal cl As Collection)
    On Error Resume Next
    
    ' キャプション保存
    Dim captionBak As String
    captionBak = myForm.Caption
    '砂時計ポインタ
    myForm.MousePointer = vbHourglass
    
    Dim da(), da2() As Variant
    Dim i, r, c, sp, ep As Long
    Dim totalCnt As Long
    Dim totalCol As Long

    ' エクセル起動
    Set oXlsApp = CreateObject("Excel.Application")
    If oXlsApp Is Nothing Then
        ' キャプションを戻す
        myForm.Caption = captionBak
        ' 通常ポインタ
        myForm.MousePointer = vbDefault
        MsgBox "Microsoft Excel起動失敗　"
        Exit Sub
    End If
    
    ' エクセル非表示
    oXlsApp.Application.Visible = False
    oXlsApp.Application.DisplayAlerts = False
    ' ブック追加
    oXlsApp.Application.Workbooks.Add
    ' シート選択
    Set oSheet = oXlsApp.Worksheets(1)
    
    ' セルにデータを転送
    totalCnt = cl.Count
    If totalCnt > 65536 Then totalCnt = 65536
    For i = 0 To Int((totalCnt - 1) / CPMAXROW)
        sp = i * CPMAXROW
        ep = cl.Count - 1
        If ep - sp >= CPMAXROW Then ep = sp + (CLng(CPMAXROW) - 1)
        totalCol = UBound(cl.Item(1)) + 1
        If totalCol > 256 Then totalCol = 256
        ReDim da(ep - sp, totalCol - 1)
        For r = sp To ep
            da2 = cl.Item(r + 1)
            For c = 0 To UBound(da, 2)
                da(r - sp, c) = da2(c)
                DoEvents
            Next c
        Next r
        If UBound(da) >= 0 Then
            Set oRange = oSheet.Range( _
                RowColToA9(sp + 1, 1, ep + 1, UBound(da, 2) + 1))
            oRange.Value = da
            myForm.Caption = captionBak & " : " & Int(r / totalCnt * 100) & "%"
            DoEvents
        End If
    Next i

    ' エクセル表示
    oSheet.Range("A:IV").EntireColumn.AutoFit
    oXlsApp.Application.Worksheets(1).Activate
    oXlsApp.Application.DisplayAlerts = True
    oXlsApp.Application.Visible = True
    Set oRange = Nothing
    Set oSheet = Nothing
    Set oXlsApp = Nothing
    
    ' キャプションを戻す
    myForm.Caption = captionBak
    ' 通常ポインタ
    myForm.MousePointer = vbDefault
End Sub

' 関数名    : UnloadExcel
' 機能説明  : エクセルのアンロード
Public Sub UnloadExcel()
    On Error Resume Next

    ' エクセルを閉じる
    If oXlsApp Is Nothing = False Then oXlsApp.Quit
    Set oRange = Nothing
    Set oSheet = Nothing
    Set oXlsApp = Nothing
    
End Sub

' 関数名    : RowColToA9
' 返り値    : RANGE形式文字列
' 引き数    : r1(i) : 左上行
' 　　　    : c1(i) : 左上桁
' 　　　    : r2(i) : 右下行
' 　　　    : c2(i) : 右下桁
' 機能説明  : ExcelのRANGE形式の文字列生成
Private Function RowColToA9(ByVal r1 As Long, ByVal c1 As Long, _
                        ByVal r2 As Long, ByVal c2 As Long) As String
    On Error Resume Next
    
    ' 左上位置
    Dim d1, d2 As String
    d1 = Chr(65 + ((c1 - 1) Mod 26))
    If c1 > 26 Then d1 = Chr(65 + Int(c1 / 26) - 1) & d1
    d1 = d1 & r1
    
    ' 右下位置
    d2 = Chr(65 + ((c2 - 1) Mod 26))
    If c2 > 26 Then d2 = Chr(65 + Int(c2 / 26) - 1) & d2
    d2 = d2 & r2

    RowColToA9 = d1 & ":" & d2
End Function