|
|||||
<このサンプルの概要> 2次元配列形式のデータをそのままエクセルシートにコピーして表示します。コピーされ る各行はVBの1次元配列で、それらをCollectionオブジェクトとして集めて、このモジ ュールに引数渡しします。Collectionオブジェクトを使用し、一気にコピーする事で1セ ルずつコピーをするより何倍(何十倍?)も処理が早くなります。プログラムからエクセ ルにデータ出力する際の重要な事は出来るだけまとめてコピーする事だと思います。 他のVB6のサンプルはこちらです。 エクセルを起動しいろいろ操作するサンプル(VB6) VB.NETのサンプルはこちらです。 エクセルを使用した帳票印刷のサンプル(VB.NET) 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 |