green

Lotusnut >> Soft >> Visual Basic for Application >> VBA

インタプリンタ言語「EXCEL_VBA」とは・・・

  1. ■ エラーに対応した雛形
  2. ■ 汎用的な再利用可能なfunction(関数)
  3. ■ データベースライクなfunction
  4. ■ シートをデータベースに利用
  5. ■ DAOデータベースに接続(SQL)
  6. ■ 処理速度を重視したコードの作り方
  7. ■ その他役に立ちそうなコード(おまけ)

■ エラーに対応した雛形

まず自分がソースを書くのに役立つテンプレートを紹介します。(コメントとしてテキストファイルに保存してます。)

    '*************一般的なプロシージャの様式 2018 UpDate
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) :
    ' 入  力(Input) :
    ' 受渡し(Delivery) :
    ' 戻  値(Return) :
    ' 出  力(Output) :
    ' 注  釈(Notes) :
    ' 使用方法(Usage) :
    ' 履  歴(History): Ver 0.0.0 2018 Original
    '
    'On Error GoTo ErrTrap

    '変数の宣言

    '戻り値の初期化 false

    '引数の検証&変換

    '変数への代入

    '/* 処理の実行 */

    '正常な戻り値 true

    'Exit Function

    'エラートラップ

    'ErrTrap:
    ' Debug.Print " エラー : " & Err.Description
    ' On Error GoTo 0

■ 汎用的な再利用可能なfunction(関数)

上記のテンプレートをコピペして上から順にソースを書いていきます。

    Public Function dfOpenDialog(ByVal strfilter As String) As String
    '
    ' 作  者(Writer) : fivejoy@lotusnut.net
    ' 目  的(Aim) : 開くダイアログを開きパスを取得
    ' 使用方法(Usage) : strPath = dfOpenDialog("Excel Files,*.xlsx;*.xlsm")
    ' 履  歴(History): Ver 0.0.0 2018 Original
    '
    On Error GoTo ErrTrap

    '変数の宣言
    Dim strfname As Variant

    '戻り値の初期化
    dfOpenDialog = ""

    '/* 処理の実行 */

    'ファイルを開くダイアログの表示

    strfname = Application.GetOpenFilename(strfilter)

    'キャンセルなら
    If strfname = False Then Exit Function

    '正常な戻り値
    dfOpenDialog = strfname

    Exit Function

    'エラートラップ

    ErrTrap:
      Debug.Print "dfOpenDialog エラー : " & Err.Description
      On Error GoTo 0

    End Function

ページTOPへ

データベースライクなExcelファイルを作成します。

    Public Function dfCreatefile(ByVal strfname As String, _
                    ByRef strWsName As Variant, _
                    ByRef strFlds As Variant, _
                    Optional ByRef vntType As Variant) As Boolean

    '
    ' 作  者(Writer) :
    ' 目  的(Aim) : * データファイルを新規に作成
    ' 使用方法(Usage) : * If Not dfCreatefile(strPath, vntWs, vntflds, vntFldType) Then _
                 Debug.Print "新規DBファイルの作成に失敗しました"
    ' 履  歴(History) : Ver 0.0.0 2003/6/20 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim lngWsCount As Long
    Dim lngFldCount As Long
    Dim newWB As Workbook
    Dim Ws As Worksheet
    Dim intCount As Integer

    '戻り値の初期化
    dfCreatefile = False

    '配列の添字数取得
    lngWsCount = dfArrayCount(strWsName)
    lngFldCount = dfArrayCount(strFlds)

    '***** プロシージャ処理の実行 *****

    'Newブックに対するシート数の設定

    Application.SheetsInNewWorkbook = lngWsCount + 1

    'NEWブックの作成
    Set newWB = Workbooks.Add

    '変数の再初期値
    lngWsCount = 0

    'シート名の設定・フィールド名の設定
    For Each Ws In newWB.Worksheets
      Ws.Name = strWsName(lngWsCount)
      'フィールド名
      For intCount = 0 To lngFldCount
        Ws.Cells(1, intCount + 1).Value = strFlds(intCount)
        '擬似タイプの設定
        Ws.Cells(2, intCount + 1).Value = vntType(intCount)
      Next intCount
      lngWsCount = lngWsCount + 1
    Next Ws

    '名前設定(例 : Service2000.xlsx VIST版以上なら旧形式で保存)
    If CInt(Application.Version) >= 12 Then
      newWB.SaveAs Filename:=strfname, FileFormat:=xlWorkbookDefault
    Else
      newWB.SaveAs Filename:=strfname
    End If

    'ファイルクローズ
    newWB.Close

    '変数の開放
    Set newWB = Nothing

    '成功を返す
    dfCreatefile = True

    Exit Function

    'エラートラップ
    ErrTrap:
      Debug.Print "dfCreatefileエラー : " & Err.Description
      On Error GoTo 0

    End Function

ページTOPへ

■ シートをデータベースに利用

    Public Function dfGetRecData(ByRef Ws As Worksheet, _
                    ByVal lngID As Long) As Variant()
    '
    ' 作  者(Writer) : Lotusnut.net
    ' 目  的(Aim) : * IDから1レコード分のデータを配列に格納
    ' 入  力(Input) : * IDの範囲,ID番号
    ' 戻  値(Return) : * 検索条件 strFld レコードの strFindFld列文字
    ' 履  歴(History) : Ver 0.0.0 2003/10/09 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim tagRng As Range
    Dim rng As Range
    Dim lngflds As Long

    Dim intCount As Integer
    Dim vntData() As Variant

    'インスタンス
    Set tagRng = Ws.Range("A1:CA1")

    '配列の初期化
    lngflds = dfDbCount(tagRng)
    ReDim vntData(lngflds)
    intCount = 0

    '再インスタンス
    Set tagRng = Ws.Range("A2:A5000")

    '***** プロシージャ処理の実行 *****

    'IDの検索

    For Each rng In tagRng
    If rng.Value = "" Then Exit For
    '見つかったら strFinfFld列のデータを返す
    If lngID = rng.Value Then
    For intCount = 0 To lngflds - 1
    vntData(intCount) = Ws.Cells(rng.Row, intCount + 1).Value
    Next
    End If
    Next

    'インスタンス開放
    Set tagRng = Nothing

    '成功(配列データを返す)
    dfGetRecData = vntData

    Exit Function

    'エラートラップ
    ErrTrap:
    Debug.Print "dfGetRecData : " & Err.Description
    On Error GoTo 0

    End Function

ページTOPへ

■ DAOデータベースに接続(SQL)

    Public Sub dfDBLoadSql(ByVal strPath As String, _
               ByVal mySql As String, _
               Optional ByRef lngRsCount As Long)
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : データベースのロード
    ' 注  釈(Notes) : 有効なレコードカウントを返す
    ' 履  歴(History): Ver 0.0.0 2005 Original
    '
    >
    On Error GoTo ErrTrap

    '/* 処理の実行 */

    'データベースの設定

    Set xldb = OpenDatabase(strPath, False, False, "Excel 12.0 Xml;HDR=YES;")
    Set Rs = xldb.OpenRecordset(mySql)

    '必要なら現在のレコードカウントを返す
    lngRsCount = Rs.RecordCount

    Exit Sub

    'エラートラップ
    ErrTrap:
      Debug.Print "dfDBLoadSqlエラー : " & Err.Description
      On Error GoTo 0

    End Sub

ページTOPへ

データベース用のEXCELブックを作成

    Public Function dfCreateDB(ByVal strPath As String, _
               ByRef vntTbl As Variant, _
               ByRef vntflds As Variant, _
               ByRef vntType As Variant) As Boolean
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : 新規にDBを作成する
    ' 履  歴(History): Ver 0.0.0 2006 Original
    '
    On Error GoTo ErrTrap

    '変数の宣言
    Dim dbxl As DAO.Database

    '戻り値の初期化
    dfCreateDB = False

    '/* 処理の実行 */

    'データベースファイルの存在確認

    If dfIsFileExists(strPath) Then
     Debug.Print strPath & "は既に存在しています。"
     Exit Function
    End If

    '********* データベースの設定***********

    'ファイル新規作成
    Set xldb = DBEngine.Workspaces(0).CreateDatabase(strPath, dbLangJapanese)

    'テーブルの作成
    If Not dfCreateTable(xldb, vntTbl, vntflds, vntType) Then Debug.Print "作成失敗"

    '閉じる
    xldb.Close

    'インスタンスの開放
    Set xldb = Nothing

    '正常な戻り値
    dfCreateDB = True

    Exit Function

    'エラートラップ
    ErrTrap:
    Debug.Print "dfCreateDB エラー : " & Err.Description
    On Error GoTo 0

    End Function

ページTOPへ

    Public Function dfGetRecData(ByVal lngID As Long) As Variant()
      '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : * IDから1レコード分のデータを配列に格納
    ' 入  力(Input) : * path,table名,ID番号
    ' 戻  値(Return) : * 検索条件 strFld レコードの strFindFld列文字
    ' 履  歴(History) : Ver 0.0.0 2003/10/09 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim fld As Field
    Dim intcount As Integer
    Dim vntData() As Variant
    Dim intFlds As Integer

    '戻り値初期値
    dfGetRecData = Null
    '配列の初期化
    intFlds = Rs.Fields.Count - 1
    ReDim vntData(intFlds)
    intcount = 0

    '***** プロシージャ処理の実行 *****

    With Rs
      'レコードの先頭行に
    .MoveFirst
    Do Until .EOF
    '見つかったら strFinfFld列のデータを返す
    If lngID = .Fields("ID") Then
    For Each fld In .Fields
    vntData(intcount) = fld.Value & ""
    intcount = intcount + 1
    Next
    Exit Do
    End If
    '次のレコード
    .MoveNext

    Loop
    End With

    '成功(配列データを返す)
    dfGetRecData = vntData

    Exit Function

    'エラートラップ
    ErrTrap:
    Debug.Print "dfGetRecData : " & Err.Description
    On Error GoTo 0

    End Function

ページTOPへ

■ 処理速度を重視したコードの作り方

エクセルVBAを作成するうえで処理速度を早くする工夫は、すごく重要です。特にセルになにか文字等を入力する時、1セルずつ入力していたら、莫大な処理時間となって動作が重くなります。できるだけ配列変数などに入れてから最後に全てのデータを一緒に出力した方が、確実に効率的なソースを書くことができます。またその方が冗長ではなくきれいなコードにもなります。

    Private Function dfSetWeekDays(ByVal Ws As Worksheet, _
                   ByVal intFstWeekDay As Integer) As Boolean
    '
    ' 作  者(Writer) : Lotusnut.net
    ' 目  的(Aim) : * セルに曜日を入力
    ' 入  力(Input) : * 月の1日目
    ' 戻  値(Return) : * 成功か否か
    ' 履  歴(History) : Ver 0.0.0 2003/3/3 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim strWeekDays() As String
    Dim intLastDay As Integer
    Dim intyear As Integer
    Dim intMonth As Integer

    '戻り値の初期化
    dfSetWeekDays = False

    '変数の初期化
    intyear = Ws.Range("yer").Value + 2018
    intMonth = Ws.Range("mon").Value

    '***** プロシージャ処理の実行 *****

    '月の最終日の取得

    intLastDay = dfLastDay(intMonth, intyear)

    '曜日配列の取得
    strWeekDays = dfWeekDays(intLastDay, intFstWeekDay)

    'セルに曜日を入力
    Ws.Range("F7:AJ7").Value = strWeekDays

    '成功したら
    dfSetWeekDays = True

    Exit Function

    'エラートラップ
    ErrTrap:
    Debug.Print "dfSetWeekDaysエラー : " & Err.Description
    On Error GoTo 0

    End Function
    '****************************************************************************************************** Private Function dfWeekDays(ByVal intLastDay As Integer, _
                 ByVal intFstWeekDay As Integer) As String()
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : * 単なる漢字日付を配列で返すグローバル変数の代わり
    ' 履  歴(History) : Ver 0.0.0 2003/3/3 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim strWeekDay As Variant
    Dim tagWeekDay(30) As String
    Dim intday As Integer
    Dim intCount As Integer
    Dim intfwd As Integer
    Dim tagDay As Integer

    '変数の初期化
    strWeekDay = Array("日", "月", "火", "水", "木", "金", "土")

    '***** プロシージャ処理の実行 *****

    '月初めの曜日が配列
    intfwd = intFstWeekDay - 1

    '配列に曜日を入力(1日から28日まで)
    For intday = 0 To 27 Step 7
      '一週間を配列に代入
      For intCount = 0 To 6
        tagWeekDay(intday + intCount) = strWeekDay(intfwd)
        If intfwd = 6 Then
          intfwd = 0
        Else
          intfwd = intfwd + 1
        End If
      Next intCount
    Next intday

    '残りの日の曜日
    tagDay = intLastDay Mod 28

    '最終日により処理を分岐
    Select Case tagDay
     Case 0 '28日
      tagWeekDay(28) = "/"
      tagWeekDay(29) = "/"
      tagWeekDay(30) = "/"
     Case 1 '29日(うるう年)
      tagWeekDay(28) = tagWeekDay(21)
      tagWeekDay(29) = "/"
      tagWeekDay(30) = "/"
     Case 2 '30日
      tagWeekDay(28) = tagWeekDay(21)
      tagWeekDay(29) = tagWeekDay(22)
      tagWeekDay(30) = "/"
     Case Else
      tagWeekDay(28) = tagWeekDay(21)
     tagWeekDay(29) = tagWeekDay(22)
     tagWeekDay(30) = tagWeekDay(23)
    End Select

    '配列変数を返す
    dfWeekDays = tagWeekDay

    Exit Function

    'エラートラップ
    ErrTrap:
      Debug.Print "dfWeekDaysエラー : " & Err.Description
     On Error GoTo 0

    End Function

ページTOPへ

■ その他役に立ちそうなコード(おまけ)

拙いコードですが、自分の仕事にも結構!役立っているコードを紹介します。まず最初に月のソート。EXCELのソートは自然に使うと、例えば会計簿などで日付順にソートしようと思っても1月からの順になってしまい。今はどうだかわかりませんが、昔は会計年度(4月〜3月)順にするには自作しかありません。

    Private Function dfmysort(ByRef vntData As Variant, _
                  ByRef lngRow As Long) As Boolean
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : 4月〜3月のデータを並び替える mysort版
    ' 履  歴(History): Ver 0.0.0 2014 Original
    ’ 列の例 : A列なし B列(月) C列(日) D列(適要) E列(節) F列(数量)
             G列(単価) H列(収入) I列(支出) J列(差引残)は標準関数
    '

    On Error GoTo ErrTrap
    '変数の宣言
    Dim tmpData As Variant
    Dim vntDay As Variant
    Dim rng As Range
    Dim Allrng As Range
    Dim vntCol As Variant
    Dim lngCount As Long
    Dim intCount As Integer
    Dim vntMon As Variant
    Dim lngMax As Long
    Dim i As Integer
    Dim l As Long
    Dim x As Integer

    '戻り値の初期化
    dfmysort = False

    'インスタンス(余裕を持った範囲)
    Set Allrng = Range("D4:D1000")

    '/* 処理の実行 */

    '列は配列でなく cell(lngCol,lngRow)で処理してもよい

    vntCol = Array("B", "C", "D", "E", "F", "G", "H", "I")

    '0は空行=最下行に、日の空は最上位
    vntMon = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3, 0)

    'データ量(添え字の決定)
    lngMax = dfVlCount(Allrng) - 1

    '配列の添え字
    ReDim tmpData(lngMax, 7)
    ReDim vntDay(lngMax, 7)
    ReDim vntData(lngMax, 7)

    'データ数の検証
    For Each rng In Allrng
      If rng.Value <> "" Then
        For intCount = 0 To 7
          tmpData(lngCount, intCount) = Range(vntCol(intCount) & rng.Row)
        Next intCount
        lngCount = lngCount + 1
      End If
    Next

    '一旦日付順に並び替える
    For intCount = 0 To 31
      For lngCount = 0 To lngMax
        If tmpData(lngCount, 1) = intCount Then
          For i = 0 To 7
            vntDay(l, i) = tmpData(lngCount, i)
          Next i
          l = l + 1
        End If
      Next lngCount
    Next intCount

    '年度における月(4月に始まり3月に終了)データを変数に代入
    l = 0
    For intCount = 0 To 12
      For lngCount = 0 To lngMax
        If vntDay(lngCount, 0) = vntMon(intCount) Then
          For i = 0 To 7
            vntData(l, i) = vntDay(lngCount, i)
          Next i
          l = l + 1
        End If
      Next lngCount
    Next intCount

    'インスタンス開放
    Set Allrng = Nothing

    '正常な戻り値
    lngRow = lngMax
    dfmysort = True

    Exit Function

    'エラートラップ
    ErrTrap:
      Debug.Print "dfmysort エラー : " & Err.Description
      On Error GoTo 0

    End Function


    '******************************************************************************************************
    次に リスト化するコントロールにデータベースライクなセルの任意のフィールドのデータを取り入れる。
    Public Function dfOverListDB(ByRef ctrl As Variant, _
                    ByRef tagRng As Range) As Boolean
    '
    ' 作  者(Writer) : lotusnut.net
    ' 目  的(Aim) : * リスト内で重複しない文字列をリスト化
    ' 入  力(Input) : * ListBoxコントロール,path,table名,フィールド名
    ' 履  歴(History) : Ver 0.0.0 2003/5/6 Original
    '

    On Error GoTo ErrTrap

    'ローカル変数の宣言
    Dim Ws As Worksheet
    Dim vntData As Variant
    Dim rng As Range
    Dim tmpArray() As Variant
    Dim myArray() As Variant
    Dim lngCount As Long
    Dim intCount As Integer

    '戻り値の初期化
    dfOverListDB = False

    '引数の検証&変換
    If Not (TypeOf ctrl Is ComboBox) And Not (TypeName(ctrl) = "ListBox") Then
      Debug.Print "dfSetListBoxDBコントロールエラー"
      Exit Function
    End If

    'インスタンス
    Set Ws = tagRng.Worksheet

    '***** プロシージャ処理の実行 *****

    'ターゲットデータの数

    lngCount = dfDbCount(Ws.Range("A2:A5000"))
    '配列の初期化
    ReDim tmpArray(lngCount, 1)
    lngCount = 0

    '該当項目をリスト化
    For Each rng In tagRng
      vntData = rng.Value
      If vntData = "" Then Exit For
      '重複リストでない
      If Not dfMatchFound(ctrl, vntData) Then
        ctrl.AddItem vntData
        tmpArray(lngCount, 0) = Ws.Range("A" & rng.Row)
        '主力表示は項目の欄
    tmpArray(lngCount, 1) = vntData
        lngCount = lngCount + 1
      End If
    Next

    'インスタンス
    Set Ws = Nothing

    'データが無ければ
    If lngCount = 0 Then Exit Function

    ReDim myArray(lngCount - 1, 1)
    '有効なデータのみコピー
    For intCount = 0 To lngCount - 1
      myArray(intCount, 0) = tmpArray(intCount, 0)
      myArray(intCount, 1) = tmpArray(intCount, 1)
    Next intCount

    'コントロールの初期化
    If ctrl.ListCount > 0 Then ctrl.Clear

    'コントロールの設定
    ctrl.ColumnCount = 2
    ctrl.ColumnWidths = 0 'ID番号を非表示
    ctrl.BoundColumn = 1 'コントロールの値の規定値=ID
    ctrl.TextColumn = 2 'テキスト表示の規定値

    'コントロールに関連付け
    ctrl.List() = myArray

    'ここまでくれば完全成功
    dfOverListDB = True

    Exit Function

    'エラートラップ
    ErrTrap:
      MsgBox "dfOverListDB エラー : " & Err.Description
      On Error GoTo 0

    End Function

ページTOPへ