空腹おやじのログと備忘録

VBA（主にExcel）でいろいろな実験的な事とか、Linuxのコマンドとか設定とかについて忘れないように、あれこれと・・・

トップ > プログラミング

【VBA】偶数判定、奇数判定

VBA プログラミング

主に偶数判定のための私的メモ。

判定式結果
偶数の場合奇数の場合
偶数判定( N Eqv 0 ) And 101
( N And 1 ) = 0TrueFalse
奇数判定N And 101
( N And 1 ) = 1TrueFalse


Eqv（XOr の逆パターン）

値１ 値２ 値１ Eqv 値２
False False True
False True False
True False False
True True True


Bit版

値１ 値２ 値１ Eqv 値２
0 0 1
0 1 0
1 0 0
1 1 1


整数版

値１ 値２ 値１ Eqv 値２
0 0 -1 (&HFFFF)
0 1 -2 (&HFFFE)
0 2 -3 (&HFFFD)
1 0 -2 (&HFFFE)
2 0 -3 (&HFFFD)
&HFFFF 0 0
&HFFFF 1 1
&HFFFF 2 2
&HFFFF 3 3
&HFFFE 0 0
&HFFFE 1 0
&HFFFE 2 3
&HFFFE 3 2

【VBA】同じデータのセルを結合（Union未使用版）

VBA Excel プログラミング

下記のサイトで、同じデータのセルを結合するということで、Unionを使ってRangeをまとめて最後にMergeという処理を行っていました。

kouten0430.hatenablog.com

これはこれで良いのですが、非連続データならともかく、連続データである場合には、
個人的には、「何度もUnionせずに、範囲（開始行と終了行）を取得してMerge」とする方が好みなので、作ってみました。

Do Until の2重ループにして、以下のようなソースに。
（縦方向のマージ処理のみです）

外側のループで、基準となる行を進めていって、
内側のループで、基準となる値が終わる行を取得しています。

Public Sub doMerge()

    Dim r   As Range

    Set r = Sheet1.Range("A1").CurrentRegion
    Set r = r.Resize(r.Rows.Count - 1).Offset(1)

    Call MergeSameValueCellsV(r)

    Debug.Print "Done."

End Sub


Private Sub MergeSameValueCellsV(ByRef rTarget As Range)

    Const TARGGET_COL   As String = "A"

    Dim ws              As Worksheet
    Dim lCurrentRow     As Long
    Dim lNextRow        As Long
    Dim lEndRow         As Long
    Dim lMergeBeginRow  As Long
    Dim lMergeEndRow    As Long
    Dim vBaseValue      As Variant

    If rTarget Is Nothing Then
        Exit Sub
    ElseIf rTarget.Rows.Count = 1 Then
        Exit Sub
    End If

    Application.DisplayAlerts = False

    lCurrentRow = rTarget.Row
    lEndRow = rTarget.Row + rTarget.Rows.Count - 1

    Set ws = rTarget.Parent

    Do Until lCurrentRow > lEndRow

        lMergeBeginRow = lCurrentRow
        lMergeEndRow = lMergeBeginRow

        vBaseValue = ws.Range(TARGGET_COL & CStr(lCurrentRow)).Value

        lNextRow = lMergeBeginRow + 1

        Do Until vBaseValue <> ws.Range("A" & CStr(lNextRow)).Value
            lMergeEndRow = lNextRow

            lNextRow = lNextRow + 1
        Loop

        If lMergeEndRow > lMergeBeginRow Then
            'マージ開始行と終了行が違っていたら、マージ処理
            ws.Range(TARGGET_COL & CStr(lMergeBeginRow) & ":" & TARGGET_COL & CStr(lMergeEndRow)).Merge

            '次の処理は、マージした次の行から
            lCurrentRow = lCurrentRow + lMergeEndRow - lMergeBeginRow + 1
        Else
            'マージしないので次の行
            lCurrentRow = lCurrentRow + 1
        End If
    Loop

    Application.DisplayAlerts = True

End Sub



今日は（も？）、人のネタを元にする日・・・

【VBA】種目別に自動採番（別解）

VBA Excel プログラミング

コロ子さん（id:SNegishi）のところで、自動採番処理をやっているのを見て、ちょっと気がついた点をコメントしました。
すぐに修正版がアップされて「おぉ～、仕事はえぇなぁ」と感心していました。
koroko.hatenablog.com


そんな中で、

「Worksheet_SelectionChangeイベントで変更前の値を保持しておいく」のところを静的変数Staticを使おうとしたけど、モジュール変数として使う事がでなかった。
「プローシシャーの外では使えません」のエラーメッセージが出た。
結局上手くできず、いつもの仮置き方式。
仮置き方式でないなら、どのように作るものなのでしょうか・・・？

多分、Worksheet_SelectionChangeの中にStatic変数を置いちゃったんでしょうね。
そのままでは、他のプロシージャからは、そのStatic変数にはアクセス出来ないので、
もう少し工夫が必要ですね。

私の場合、Static変数はほとんど使うことがなくて、大抵の場合、モジュールレベルのPrivate変数で処理しちゃいます。

下記のソースの vPrevValue_ がそれに当たります。
そいつに、Worksheet_SelectionChangeイベントで、必要な条件に一致した時に値を突っ込みます。

あと、Application.EnableEvents で処理中のイベントを抑止してあげないと、不要な処理が走るようです。


あと、先頭部分で処理不要なら、即 Exit Sub するように
以下の理由により、変えてあります。

  • それ以降、何も処理が無いのが明確になる
    • If でくくった場合、「Ifの後に何か処理があるかもしれない」ので確認が必要。プロシージャが長いほど、スクロールが面倒くさい（私の場合）
  • If によるインデントが不要になる


Private変数を使って処理したソースがこれ

Private vPrevValue_    As Variant


Private Sub Worksheet_Change(ByVal Target As Range)

    Dim buf As Range

    If Target.Column <> 1 Then
        '1列目（A列）以外でイベントが発生した場合は、処理を抜ける
        Exit Sub
    ElseIf vPrevValue_ = Target.Value Then
        'データが変わっていなければ、処理を抜ける
        Exit Sub
    End If


    Application.ScreenUpdating = False
    Application.EnableEvents = False


    '初期化
    Range("B" & Target.Row).Value = ""

    'A列でフィルタ
    Range("A1").AutoFilter Field:=1, Criteria1:=Range("A" & Target.Row).Value

    'アクティブセル領域の可視範囲を取得
    Set buf = Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeVisible)

    '最大値＋1を取得
    Range("B" & Target.Row).Value = Application.WorksheetFunction.Max(buf) + 1

    'フィルター条件解除
    ActiveSheet.ShowAllData


    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '複数セルを選択している中に、未入力セルが含まれていても処理できるように
    'Target.Count = 1
    'は含めない

'    If Target.Column = 1 And Target.Count = 1 Then
    If Target.Column = 1 Then

        '複数のセルが選択されている場合、Target.Valueを代入すると、
        'vPrevValueは配列になるのでActiveCellを指定する

'        vPrevValue_ = Target.Value
        vPrevValue_ = ActiveCell.Value
    End If

End Sub

【VBA】特定の範囲内の任意の整数をインクリメント、デクリメントして次の値を求める

VBA プログラミング

条件

  • 任意の３つの整数において、以下の条件を満たす事（負の値があっても可）
    • 最小値 <= 現在値 <= 最大値
  • 範囲の最大値をインクリメントした場合、範囲の最小値を返す事。
  • 範囲の最小値をデクリメントした場合、範囲の最大値を返す事。

求める式

インクリメント、デクリメントというからには、普通に考えれば増減値は１なので、以下のようになる。

要素数 = 最大値 - 最小値 + 1

'インクリメントする場合
次の値 = ( ( 現在値 + 1 - 最小値 ) Mod 要素数 ) + 最小値

'デクリメントする場合
次の値 = ( ( 現在値 + ( 要素数 - 1 ) - 最小値 ) Mod 要素数 ) + 最小値
補足

インクリメントの場合
現在値に１を加算し、要素数の剰余を利用する。
範囲の最小値が０でない場合、最小値を０に補正して剰余を求めた後、補正した分を戻す。

デクリメントの場合
インクリメントでは、要素数に１を加算したが、デクリメントの場合は、
（要素数 - 1 ）を加算し、同様に計算する。

増減値が２以上の場合、前述の式の１の部分を変えれば良い。

要素数 = 最大値 - 最小値 + 1

'インクリメントする場合
次の値 = ( ( 現在値 + 加算する値 - 最小値 ) Mod 要素数 ) + 最小値

'デクリメントする場合
次の値 = ( ( 現在値 + ( 要素数 - 減算する値 ) - 最小値 ) Mod 要素数 ) + 最小値

ただし、以下の条件を満たす必要がある。

加算する値 >= 0
減算する値 >= 0
かつ
減算する値 <= 要素数

コード

Private Const ERROR_INVALID_PARAMETER   As Long = 87


Public Function incrementBetweenNM(ByVal lCurrentValue As Long, _
                                   ByVal lMinValue As Long, _
                                   ByVal lMaxValue As Long, _
                          Optional ByVal lOffsetValue As Long = 1) As Long

    Dim lElements   As Long

    If lMinValue > lMaxValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lMaxValue < lCurrentValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lMinValue > lCurrentValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    End If

    If lOffsetValue < 0 Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lOffsetValue > lMaxValue - lMinValue + 1 Then
        Err.Raise ERROR_INVALID_PARAMETER
    End If

    lElements = lMaxValue - lMinValue + 1

    incrementBetweenNM = ((lCurrentValue + lOffsetValue - lMinValue) Mod lElements) + lMinValue

End Function

Public Function decrementBetweenNM(ByVal lCurrentValue As Long, _
                                   ByVal lMinValue As Long, _
                                   ByVal lMaxValue As Long, _
                          Optional ByVal lOffsetValue As Long = 1) As Long

    Dim lElements   As Long

    If lMinValue > lMaxValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lMaxValue < lCurrentValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lMinValue > lCurrentValue Then
        Err.Raise ERROR_INVALID_PARAMETER
    End If

    If lOffsetValue < 0 Then
        Err.Raise ERROR_INVALID_PARAMETER
    ElseIf lOffsetValue > lMaxValue - lMinValue + 1 Then
        Err.Raise ERROR_INVALID_PARAMETER
    End If

    lElements = lMaxValue - lMinValue + 1

    decrementBetweenNM = ((lCurrentValue + (lElements - lOffsetValue) - lMinValue) Mod lElements) + lMinValue

End Function

実行例

テストコード
Public Sub getNext()

    Dim l As Long
    Dim u As Long
    Dim i As Long

    l = -3
    u = 2

    Debug.Print "最小値:" & l
    Debug.Print "最大値:" & u
    Debug.Print ""

    Debug.Print "現在値", "次の値", "前の値"

    For i = l To u
        Debug.Print i, incrementBetweenNM(i, l, u), decrementBetweenNM(i, l, u)
    Next

End Sub
実行結果
call getNext
最小値:-3
最大値:2

現在値        次の値        前の値
-3            -2             2 
-2            -1            -3 
-1             0            -2 
 0             1            -1 
 1             2             0 
 2            -3             1

おまけのテスト　その１

call getNext
最小値:1
最大値:1

現在値        次の値        前の値
 1             1             1

最大値 = 最小値 だと、次の値も前の値も、みんな同じ・・・
あたりまえか。

おまけのテスト　その２

Debug.Print i, incrementBetweenNM(i, l, u, 2), decrementBetweenNM(i, l, u, 3)

として、加算、減算する値を変えてみると

call getNext
最小値:-3
最大値:2

現在値        次の値        前の値
-3            -1             0 
-2             0             1 
-1             1             2 
 0             2            -3 
 1            -3            -2 
 2            -2            -1

【VBA】ADOを使ったテキストファイル（CSV）の読み込みについて調べてみた。ついでに、Line Input と速度を比べてみた。

VBA ADO CSV プログラミング UTF-8

タイトルに「比べてみた」と書いてあるけど、ADOでの処理や設定についてがメインだったりするので、結果だけ知りたい場合は、ずっと下の結果へ・・・

環境

この記事の内容は、以下の環境下にて確認しています。

  • Windows 10 Home 64bit
  • Office 2013 32bit

処理の流れ

  1. 事前準備
    1. Schema.ini ファイルの作成
  2. Connection オブジェクトの生成
    1. プロバイダの指定
    2. 処理対象ファイルのあるフォルダの指定
    3. プロパティの指定
    4. Open
  3. Recordset オブジェクトの生成
    1. Cursorの指定
    2. 排他処理（Lock）の指定
    3. SQLの指定
    4. Open
  4. データの取得
    1. データ読み込み
  5. 後処理
    1. Recordset オブジェクト、Connection オブジェクトを閉じて、開放

ADO

Schema.ini ファイル (テキスト ファイル ドライバー)

Schema.ini ファイルとは

Scema.ini というテーブル情報の設定ファイルを併用することで、テキストファイルの定義情報を指定し、ADOでその定義情報に従った形で読み込むとが可能となる。

Schema.ini については、以下参照。
docs.microsoft.com

Schema.ini の設定については、以下参照。
docs.microsoft.com

INIファイルの構成、書き方

INIファイルは、

  • セクション
  • キー
  • 値

から構成され、以下のように構成されている。

[セクション１]
キー11=値11
キー12=値12
キー13=値13
;コメント（必要であれば）
　・
　・
　・

[セクション２]
キー21=値21
キー22=値22
キー23=値23
　・
　・
　・

Schema.ini では、

セクション ファイル名
キー 設定項目名
値 設定項目の設定値

を書く。

設定項目

キーと値については、以下のような項目を設定することが出来る。

項目キー値備考
文字セットCharacterSet932Shift-JIS
65001UTF-8
ファイル書式FormatCSVDelimitedCSV
TabDelimitedTSV（Tab区切り）
Delimited(custom character)任意の文字での区切り
FixedLength固定長
ヘッダ行の有無ColNameHeaderTrue先頭行をフィールド名として扱う
False先頭行をデータとして扱う
フィールドのデータ型を決定するためスキャンするレコード数MaxScanRows0全レコードをスキャンする
n先頭からnレコード目までに格納されているレコードをスキャン
フィールド定義Colnフィールド名
データ型下表参照
長さ固定長の場合
Width nn
フィールド定義の構文

Coln=フィールド名 データ型 [Width 長さ]

n：列番号（Col1、Col2・・・）

データ型
以下の型を指定できます。

種別型備考
Microsoft Jet のデータ型Bit
Byte
Short
Long
Currency
Single
Double
DateTime
Text
Memo
ODBC のデータ型CharText
FloatDouble
IntegerLong Integer
LongCharBlob
Date

MaxScanRowsについて

あくまでもフィールドのデータ型を決定するためにスキャンするレコード数であって、レコードセットに取得するレコード数の制限ではないようです。
デフォルト値は、25だそうです。
dobon.net

記入例

[CSV100000.csv]
CharacterSet=932
Format=CSVDelimited
ColNameHeader=True
Col1=F1 Text
Col2=F2 Text
Col3=F3 Text
Col4=F4 Text
Col5=F5 Text
Col6=F6 Text
Col7=F7 Text
Col8=F8 Text
Col9=F9 Text
Col10=F10 Text

[CSV1000000_UTF8.csv]
CharacterSet=65001
Format=CSVDelimited
ColNameHeader=True
Col1=F1 Text
Col2=F2 Text
Col3=F3 Text
Col4=F4 Text
Col5=F5 Text
Col6=F6 Text
Col7=F7 Text
Col8=F8 Text
Col9=F9 Text
Col10=F10 Text

[Sample1.csv]
CharacterSet=932
Format=CSVDelimited
ColNameHeader=True
Col1=F1 Short
Col2=F2 Long
Col3=F3 Text

[Sample2.ssv]
CharacterSet=932
;スペース区切り "("と")"の間に、半角スペースがある
Format=Delimited( )
ColNameHeader=False
Col1=ID Short
Col2=品名 Text Width 20
Col3=金額 Integer

余談ですが、スペース区切りのフォーマットは、SSV と言われることもあるそうです。
TSVは知っていたけど、SSVとかDSVとかは知らなかった。

類似したフォーマットとして、タブで区切られた tab-separated values (TSV)や、欧文間隔 (いわゆる半角スペース) で区切られた space-separated values (SSV) などがあり、これらをまとめて character-separated values (CSV)、delimiter-separated values (DSV) とも呼ばれることも多い。

Comma-Separated Values - Wikipedia
その他

このファイルは必須ではないが、無い場合、正しくデータが読み込まれない場合があるらしい。
このファイルがない場合は、レジストリを参照するらしいけど、レジストリの値が変わっているとそれに従って動作する。
ちょっと怖い・・・

作成する場合は、CSVと同じフォルダに作成、配置する。

Connection オブジェクト

Connection オブジェクトについては、以下参照。
docs.microsoft.com

ConnectionString
対象ファイルに接続するための文字列を設定する必要があります。
以下の項目を設定します。

項目 値 備考
Provider Microsoft.ACE.OLEDB.12.0
Microsoft.Jet.OLEDB.4.0		 Office 2007以降は、ACE
それより前は、Jet
Data Source 対象ファイルのあるフォルダパス ファイルパスではない
Extended Properties Text データベースの種類が、テキストファイル
HDR=Yes １行目をヘッダとして扱う場合 Yesを指定する
１行目からデータの場合は、No を指定する
FMT=Delimited CSVファイルの場合は、Delimitedを指定
上記のデータを結合して、Connection.Open する際に渡す。
各値の間には、";" を挟む。
Extended Properties の値は、「"」で括る。

記入例

Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Datas\;Extended Properties="Text;HDR=Yes;FMT=Delimited"
ConnectionString の HDR と Schema.ini の ColNameHeader

どちらも先頭行に対する扱いの指定ですが、双方の指定が異なった場合、Schema.ini の設定が優先されるようです。

結果としては、schema.iniファイルにフィールド定義情報がある場合は、そちらが優先される。
HDR=NO の設定がある場合、先頭行もデータとして取り込まれる。

https://antonsan.net/vt/excel-db/heading-4/page-046

Command オブジェクト

Command オブジェクトについては、以下を参照。
docs.microsoft.com

以下の項目を設定します。

プロパティ 設定する値 備考
ActiveConnection Connection オブジェクト
CommandType adCmdText 引数をコマンド文字列として評価
CommandText データを取得するためのSQL テーブル名部分をファイル名とし、 [ ] で括る
ファイル名と[ ] の間にスペースを含めない
例：SELECT * FROM [Sample.csv]
SQL

ファイルから読み込むデータの指定を行う。
無条件に、全データを読み込む場合

SELECT * FROM [ファイル名]

特定のフィールドのみを指定して読み込む場合

SELECT フィールド名1,フィールド名2,・・・ FROM [ファイル名]

フィールド名nは、CSVファイルのヘッダ行に記載されている物を指定する。
HDR=No; を指定して読み込んだ場合には、ヘッダ行がないので、その場合には、
F1、F2 のように "F" + 何列目のデータかの番号 を指定する。
指定する順番は、ファイルの列の順番と一致していなくても構わない。（後ろの列を先に指定しても良い）

SELECT F1,F3 FROM [ファイル名]
SELECT F5,F2 FROM [ファイル名]

SQLでは、いろいろな事が出来るので、興味がある方は、以下のようなキーワードを例にして調べてみて下さい。
抽出条件の指定：WHERE
並べ替え：ORDER BY
集計：GROUP BY
複数ファイルの結合：JOIN
サブクエリー
ワイルドカード
UNION

カーソル

カーソルについては、以下を参照。
docs.microsoft.com

CursorLocation

クライアント側カーソルの明確な利点の 1 つは、反応が速いことです。結果セットがクライアント コンピューターにダウンロードされた後は、非常に迅速に行を参照できます。

カーソル位置の重要性 | Microsoft Docs

ファイルサイズが大きいCSVファイルの場合、上記のダウンロード相当部分に時間がかかり、結果的にサーバー側カーソルの方が速い場合もあります。
実行環境に応じたカーソル位置を選択して下さい。

選択肢は以下の通りです。
CursorLocationEnum

定数 値 備考
adUseServer 2 サーバー側
adUseClient 3 クライアント側

docs.microsoft.com

CursorType

カーソルの種類については、以下を参照。
docs.microsoft.com

選択肢は以下の通りです。
CursorTypeEnum

定数 値 備考
adOpenForwardOnly 0 前方スクロールタイプ
既定値
adOpenKeyset 1 キーセットカーソル
adOpenDynamic 2 動的カーソル
adOpenStatic 3 静的カーソル

通常の読み込み作業（先頭から最後まで１回だけ読み込む）の場合には、adOpenForwardOnly で問題ないと思います。

Recordset オブジェクト

Recordset オブジェクトについては、以下参照。
docs.microsoft.com

カーソル情報（前述）及びレコードに適用されるロックの種類を設定します。

  • CursorLocation
  • CursorType
  • LockType
LockType プロパティ

LockType プロパティについては、以下参照。
docs.microsoft.com
LockTypeEnum

定数 値 備考
adLockReadOnly 1 読み取り専用
既定値
adLockPessimistic 2 レコードごとの排他的ロック
adLockOptimistic 3 レコードごとの共有的ロック
adLockBatchOptimistic 4 共有的バッチ更新

ローカルファイルの読み込み作業の場合には、adLockReadOnly で問題ないと思います。

RecordCount

RecordsetをOpenした後に、RecordCountプロパティにより、読み込んだレコードの件数を取得できる場合があります。
CursorLocation プロパティとCursorType プロパティの組み合わせにより、以下のようになります。

CursorLocation プロパティ CursorType プロパティ RecordCount 値
adUseServer adOpenForwardOnly -1
adOpenKeyset レコード数
adOpenDynamic -1
adOpenStatic レコード数
adUseClient adOpenForwardOnly レコード数
adOpenKeyset
adOpenDynamic
adOpenStatic

データの並び順

データベースの場合、明示的にORDER BY句を使用して並びを指定しない限り、レコードの順番は保証されません。
レコードの順番がファイル内の順番と一致している必要がある場合、

  • SQLでORDER BY句を使って、並びを指定する。
  • Recordsetで、Sortプロパティを使用する。（但し、CursorLocationに、adUseClient を指定する必要あり）
  • ORDER BY句で明示的に指定できない場合には、OPENステートメントを使用して読み込む方法に切り替える。

等の対応が必要です。

ソース

以下のコードを実行するには、予め、
Microsoft ActiveX Data Objects 6.X Library
を参照設定する必要があります。

Private Const TARGET_FOLDER As String = "C:\Datas\"
Private Const TARGET_NAME   As String = "CSV10.csv"

Public Sub readByAdo()

    Dim cn  As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs  As ADODB.Recordset
    Dim lRecords    As Long
    Dim i           As Long

    Dim sgStart     As Single
    Dim sgStop      As Single

    sgStart = Timer

    On Error GoTo ERR_EXIT

    Set cn = New ADODB.Connection

    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
            & "Data Source=" & TARGET_FOLDER & ";" _
            & "Extended Properties=""Text;" _
            & "HDR=Yes;" _
            & "FMT=Delimited"""

    Set cmd = New ADODB.Command

    Set cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    'データを取得するためのSQL
    cmd.CommandText = "SELECT * FROM [" & TARGET_NAME & "]"

    Set rs = New ADODB.Recordset

    'カーソルとロックの設定
    rs.CursorLocation = adUseServer
    rs.CursorType = adOpenForwardOnly
    rs.LockType = adLockReadOnly

    rs.Open cmd

    'rs.RecordCountを取得するには
    '１．adUseClientを使用する
    '   （CursorTypはどれを指定しても可）
    'または
    '２．adUseServerを使用し、かつ
    '   CursorTypeを次のいずれかにする
    '       adOpenKeyset
    '       adOpenStatic
'    lRecords = rs.RecordCount
    lRecords = 10

    Do Until rs.EOF
        For i = 0 To rs.Fields.Count - 1
            Debug.Print rs.Fields(i).Value & " ";
        Next i

        Debug.Print ""

        rs.MoveNext
    Loop

ERR_EXIT:
    If Err.Number <> 0 Then
        'エラーがあればログ出力
        Debug.Print "[" & Err.Source & "]" & "[" & CStr(Err.Number) & "] " & Err.Description
    End If

    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then
            'レコードセットのインスタンスが生成されていて、かつ開いていたら、閉じる
            rs.Close
        End If

        Set rs = Nothing
    End If

    If Not cmd Is Nothing Then
        'アクティブコネクションへの参照を破棄する
        Set cmd.ActiveConnection = Nothing

        Set cmd = Nothing
    End If

    If Not cn Is Nothing Then
        If cn.State = adStateOpen Then
            'コネクションのインスタンスが生成されていて、かつ接続済みならば、閉じる
            cn.Close
        End If

        Set cn = Nothing
    End If

    sgStop = Timer

    Debug.Print "Done. [ " & Format$(sgStop - sgStart, "0.00") & " sec.][ " & CStr(lRecords) & " records.]"

End Sub

サンプルデータ

ヘッダ行あり。
１０列×１０レコード。

F1,F2,F3,F4,F5,F6,F7,F8,F9,F10
AA0000001,AB0000001,AC0000001,AD0000001,AE0000001,AF0000001,AG0000001,AH0000001,AI0000001,AJ0000001
AA0000002,AB0000002,AC0000002,AD0000002,AE0000002,AF0000002,AG0000002,AH0000002,AI0000002,AJ0000002
AA0000003,AB0000003,AC0000003,AD0000003,AE0000003,AF0000003,AG0000003,AH0000003,AI0000003,AJ0000003
AA0000004,AB0000004,AC0000004,AD0000004,AE0000004,AF0000004,AG0000004,AH0000004,AI0000004,AJ0000004
AA0000005,AB0000005,AC0000005,AD0000005,AE0000005,AF0000005,AG0000005,AH0000005,AI0000005,AJ0000005
AA0000006,AB0000006,AC0000006,AD0000006,AE0000006,AF0000006,AG0000006,AH0000006,AI0000006,AJ0000006
AA0000007,AB0000007,AC0000007,AD0000007,AE0000007,AF0000007,AG0000007,AH0000007,AI0000007,AJ0000007
AA0000008,AB0000008,AC0000008,AD0000008,AE0000008,AF0000008,AG0000008,AH0000008,AI0000008,AJ0000008
AA0000009,AB0000009,AC0000009,AD0000009,AE0000009,AF0000009,AG0000009,AH0000009,AI0000009,AJ0000009
AA0000010,AB0000010,AC0000010,AD0000010,AE0000010,AF0000010,AG0000010,AH0000010,AI0000010,AJ0000010

実行結果

call readByAdo
AA0000001 AB0000001 AC0000001 AD0000001 AE0000001 AF0000001 AG0000001 AH0000001 AI0000001 AJ0000001
AA0000002 AB0000002 AC0000002 AD0000002 AE0000002 AF0000002 AG0000002 AH0000002 AI0000002 AJ0000002
AA0000003 AB0000003 AC0000003 AD0000003 AE0000003 AF0000003 AG0000003 AH0000003 AI0000003 AJ0000003
AA0000004 AB0000004 AC0000004 AD0000004 AE0000004 AF0000004 AG0000004 AH0000004 AI0000004 AJ0000004
AA0000005 AB0000005 AC0000005 AD0000005 AE0000005 AF0000005 AG0000005 AH0000005 AI0000005 AJ0000005
AA0000006 AB0000006 AC0000006 AD0000006 AE0000006 AF0000006 AG0000006 AH0000006 AI0000006 AJ0000006
AA0000007 AB0000007 AC0000007 AD0000007 AE0000007 AF0000007 AG0000007 AH0000007 AI0000007 AJ0000007
AA0000008 AB0000008 AC0000008 AD0000008 AE0000008 AF0000008 AG0000008 AH0000008 AI0000008 AJ0000008
AA0000009 AB0000009 AC0000009 AD0000009 AE0000009 AF0000009 AG0000009 AH0000009 AI0000009 AJ0000009
AA0000010 AB0000010 AC0000010 AD0000010 AE0000010 AF0000010 AG0000010 AH0000010 AI0000010 AJ0000010
Done. [ 0.31 sec.][ 10 records.]

参考データ

Open + Line Input との速度比較

Open ステートメント + Line Input ステートメントを使用したコードと速度を比較してみた。

使用したコード
Public Sub readByOpen()

    Dim iFileNo     As Integer
    Dim sLine       As String
    Dim vLineItems  As Variant
    Dim lRecords    As Long
    Dim vRecords()  As Variant
    Dim sgStart     As Single
    Dim sgStop      As Single

    sgStart = Timer

    lRecords = 0

'    ReDim vRecords(lRecords)
    ReDim vRecords(9)

    iFileNo = FreeFile

    Open TARGET_FOLDER & TARGET_NAME For Input As iFileNo

    'ヘッダ行読み捨て
    Line Input #iFileNo, sLine

    Do Until EOF(iFileNo)
        Line Input #iFileNo, sLine

        vLineItems = Split(sLine, ",")

'        ReDim Preserve vRecords(lRecords)

        vRecords(lRecords) = vLineItems

        lRecords = lRecords + 1
    Loop

    Close iFileNo

    sgStop = Timer

    Debug.Print "Done. [ " & Format$(sgStop - sgStart, "0.00") & " sec.][ " & CStr(lRecords) & " records.]"

End Sub
結果

単位は秒。
各レコード、各フィールドの値のDebug.Printなし。
レコード数が少ない場合は、Open + Line Input の方が速い。
100,000件以上では、ADOの方が速く、件数が増えるほど差が大きくなっている。

レコード数readByAdoreadByOpen
Preserveあり		readByOpen
Preserveなし
100.280.000.00
10,0000.330.110.11
100,0000.721.090.92
500,0002.4310.774.53
1,000,0004.5433.509.09

文字セット（Shift-JIS と UTF-8）の違いによる比較

同一内容で文字コードが異なるファイルを処理して速度を比較してみた。
レコード数： 1,000,000件
Schema.ini あり

結果

文字セット時間（秒）
Shift-JIS4.68
UTF-84.06
UTF-8の方が、約15%速かった。

カーソル、LockTypeによる影響

今回は、省略しましたが、

  • CursorLocation
  • CursorType
  • LockType

が変わると、処理時間も変わるようです。
機会があれば、まとめて掲載するかも知れません。

類似記事

2019/10/26 追記
UTF-8 の読み込み処理として、ADODB.Recordset と ADODB.Stream の比較記事があります。
z1000s.hatenablog.com
z1000s.hatenablog.com

【VBA】任意のRangeの先頭１行を除いたRangeを簡単に取得する

VBA プログラミング Excel

Excelでデータを入力していると、１行目にヘッダ行があって、実際のデータは２行目からということはよくあると思います。
VBAで何らかの処理を行っている際に、ヘッダ行を含んだRangeは取得済みだけど、ヘッダ行を除いた部分をRangeとして取得したい場合、今までは、最終行を取得して２行目から最終行までと指定していたのですが、別のアプローチがあることに気が付いてしまいました。

2019/5/22 修正
ヘッダ行を含むデータのRangeに対して、
1.ヘッダ行分、下にOffset
2.ヘッダ行分、行数をマイナスResize
でいけるんじゃない？

コメント欄で、jinoji さんからのご指摘にあるように、上記の順番では特定の条件下でエラーになるため、以下のようにするべきでしたので訂正しました。

ヘッダ行を含むデータのRangeに対して、

  1. ヘッダ行分、行数をマイナスResize
  2. ヘッダ行分、下にOffset
Public Sub hoge()

    Dim r   As Range

    Set r = Range("A1:B10")

    Debug.Print "Original Range　　 : " & r.Address(False, False)

'    Debug.Print "ヘッダ行除外 Range : " & r.Offset(1, 0).Resize(r.Rows.Count - 1).Address(False, False)
    Debug.Print "ヘッダ行除外 Range : " & r.Resize(r.Rows.Count - 1).Offset(1, 0).Address(False, False)

End Sub

実行結果

call hoge
Original Range　　 : A1:B10
ヘッダ行除外 Range : A2:B10

ほら、大丈夫！A1がA2に変わってる。
最終行を取得しなくてもいいし、１行で取得できるし、ちょっとお得な気分。

途中に結合されたセルがあっても大丈夫みたい。
でも、最初のRangeの行数が１だと、実行時エラーになりますからね。

Offset と Resize の指定を変えれば、列方向でも出来そうだ。

【VBA】Excelで、製品の販売価格の更新情報を持つマスタから、いろいろな販売日の価格を取得する

VBA プログラミング Excel Dictionary

難しく書いたけど、要するに
ある製品の販売価格が、不定期に変わっていて、その履歴が残っている。
じゃあ、「任意のタイミングでの販売価格はいくらか？」を取得するというもの。

元ネタはこちら
https://twitter.com/ia02003812/status/1122857099669598209

　ワークシート関数だけでも出来そうだけど、データ件数が多いとなるとレスポンスが悪そう。
　VLookUpでは、複数条件で絞り込めなさそうなので多分NG.
　MAXIFS を使えば出来そうだけど、うちのExcelは 2013 なので使えない。
　他にも方法はあるのだろうけど、今回は（今回も？）VBAで・・・



データは下に載せたような感じ。
いつもの如く、乱数使いまくって・・・
データ作成のコードも下の方に載せてあるので、興味のある方はどうぞ。
同じデータは作れませんけど、近いものは作れるはずなので・・・


価格履歴：各製品の販売価格の更新情報を持つマスタ（製品名、販売価格、適用開始年月日）
f:id:Z1000S:20190508213737j:plain
重要：価格履歴データは適用開始日が昇順でソートされていないと、掲載したコードは正しく動きません。


販売トラン：各製品の販売実績データ（販売日、製品名、販売数）
f:id:Z1000S:20190508213750j:plain
「データの名称が、下記のコード中の名称と違う」とか突っ込まないで下さい。

問題点としては、販売トランにある販売日が、価格履歴の価格適用開始日と一致する保証がないので、通常の完全一致の検索が出来ない。
これを解決する手段が必要。



これについては、Dictionary を使用して、以下のようにデータを格納し、その中から該当データを取得出来るようにした。
Key：製品名
Item：「販売価格」、「適用開始年月日」をペアにした物の配列

Dictionary への動的配列の格納は、以前やっているので特に問題はない。
z1000s.hatenablog.com




テスト用データ生成コードで使っている定数とかは、上の「販売価格 更新処理コード」に記載されているので、上のコードと同じモジュールに貼り付けて使って下さい。

実行結果

f:id:Z1000S:20190509222234j:plain
製品種類数：200
価格履歴件数：8,072
販売データ件数：10,000

所要時間：0.8 ～ 0.9 秒

でした。

遅くはないと思うけど、比べる物が無いので・・・


おまけ

「(0)(0)って何？」という方向けの、"よくわからないかもしれない" 解説のようなもの。

dicItemInfo_.Item(sItemName)(0)(0)
vaItemInfo(0)(0)

配列の要素が配列なので、こういう記述になります。ハイ。

例えば
a(2)
という配列があるとして、
a(0)の要素が、b という配列の場合、b(0)を参照するには
a(0)(0)
という指定をします。

Public Sub foo()

    Dim a(2)
    Dim b(1)

    b(0) = "B00"
    b(1) = "B01"

    a(0) = b

    b(0) = "B10"
    b(1) = "B11"

    a(1) = b

    Debug.Print "A00 : " & a(0)(0)
    Debug.Print "A01 : " & a(0)(1)

    Debug.Print "A10 : " & a(1)(0)
    Debug.Print "A11 : " & a(1)(1)

End Sub

実行結果

call foo
A00 : B00
A01 : B01
A10 : B10
A11 : B11


本当は、Dictionary の Item には、構造体（ユーザー定義型）を入れたかったんですよ。
でも、出来ないみたいだったので、やむなく配列で代用しました。
その結果がこれです。