2018-12-23

枠（FromとTo）から作成されているデータを分割するための基本アルゴリズム

1,Fromで昇順に、さらにToで昇順に並び替えます。（例）Order By FROM asc, TO asc
2,S1<=S2<=E1の場合に分割・統合が必要となります。
3,
新規行を作成
S3にS2を設定
E3にE1を設定
既存行の成形
E1に(S2-1)を設定
S2に(E1+1)を設定
4,不要データを削除
S1>E1
S2>E2
S3>E3

FromとToで昇順にしているので、考えるのは以下のパターン。のみ
1,開始が同じ
S1├────────────────┤E1
S2├────────────────────────────┤E2

2 S1E1
S2>E2
S3>E3

2018-12-17

枠の分割を行うアルゴリズムVB.NET

'-----------------------------------------------------------------
' 名称を明確に統一（変更しました。）
' TARGET:分割される側につける（接頭or接尾）
' NEWRNG:分割する側につける（接頭or接尾）
' CRNT:カレント行
' PREV:１個前の行
' NEXT:１個次の行
'-----------------------------------------------------------------
 
Public Class ClsDataTableMerge
	' 【定数、変数定義領域】
	' 開始フラグ：１行データごとに処理したらTrueになる（NEWRNG側）
    Public sOK As Boolean
	' 終了フラグ：１行データごとに処理したらTrueになる（NEWRNG側）
    Public eOK As Boolean
	' 分割する側の列：NEWRNG
    Const COL_START_NEWRNG = 1
    Const COL_END_NEWRNG = 2
	' 分割される側の列：TARGET
    Const COL_START_TARGET = 1
    Const COL_END_TARGET = 2
 
	'【仕様】
	' 分割するパターンはいくつあるか？⇛下記の１３パターンになる。
	' パターンALL【分割される側の】開始番号、終了番号を同時にみる
	'①範囲が完全一致
	' S----------------------------E
	' S----------------------------E
	'②範囲が完全に含まれる
	' S----------------------------E
    '  	S-----------------E
	'③行を跨いで完全に含まれる
	' S----------------------------E
    '  	S-----------------E     	
	' S----------------------------E
 
    ''' <summary>
    ''' 2つのテーブルをマージして連番の整合性を保つ処理
    ''' </summary>
    ''' <param name="_TBL_TARGER"></param>
    ''' <param name="_TBL_NEWRNGE"></param>
    Public Sub MergeDataTables(ByRef _TBL_TARGER As DataTable, ByRef _TBL_NEWRNGE As DataTable)
        ' @
        ' @ _TBL_TARGER:分割される側のDataTable
        ' @ _TBL_NEWRANGE:分割する側のDataTable
        ' @
        ' 分割される側のインデックス
        Dim idx_TARGET As Double
        Const MAX_TARGET As Double = Double.MaxValue
 
        '分割する側のインデックス
        Dim idx_NEWRNG As Double
        Const MAX_NEWRNG As Double = Double.MaxValue
 
        Try
            ' 分割する側(NEWRNG)のデータ側でループ
            For idx_NEWRNG = 0 To MAX_NEWRNG
            	Application.DoEvents()
            	' フラグ初期化
            	sOK = False
            	eOK = False
 
            	'カレントデータを保存
            	Dim strSTART_NEWRNG_CRNT As String
            	Dim strEND_NEWRNG_CRNT As String
 
            	' 件数を超えていたら終了
            	If idx_NEWRNG > _TBL_NEWRNGE.Rows.Count - 1 Then Exit Sub
 
            	'分割する側のデータを取得（カレント）
            	strSTART_NEWRNG_CRNT = _TBL_NEWRNGE.Rows(idx_NEWRNG).Item(COL_START_NEWRNG)
            	strEND_NEWRNG_CRNT = _TBL_NEWRNGE.Rows(idx_NEWRNG).Item(COL_END_NEWRNG)
 
            	'分割する側が空白になったら終了
            	If strEND_NEWRNG_CRNT = "" Or strSTART_NEWRNG_CRNT = "" Then
                	Exit Sub
            	End If
 
            	' 分割される側(TARGET)でループ
            	For idx_TARGET = 0 To MAX_TARGET
                	Application.DoEvents()
                	'一個前のデータ
                	Dim strSTART_TARGET_PREV As String
                	Dim strEND_TARGET_PREV As String
                	'カレントデータ
                	Dim strSTART_TARGET_CRNT As String
                	Dim strEND_TARGET_CRNT As String
                	'次のデータ
                	Dim strSTART_TARGET_NEXT As String
                	Dim strEND_TARGET_NEXT As String
 
                	'一個前のデータを取得
                	If idx_TARGET > 0 Then
                    	strSTART_TARGET_PREV = _TBL_TARGER.Rows((idx_TARGET - 1)).Item(COL_START_TARGET)
                    	strEND_TARGET_PREV = _TBL_TARGER.Rows((idx_TARGET - 1)).Item(COL_END_TARGET)
                	End If
 
                	'カレントデータ取得
                	strSTART_TARGET_CRNT = _TBL_TARGER.Rows(idx_TARGET).Item(COL_START_TARGET)
                	strEND_TARGET_CRNT = _TBL_TARGER.Rows(idx_TARGET).Item(COL_END_TARGET)
                	'次の行のデータ
                	strSTART_TARGET_NEXT = _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET)
                	strEND_TARGET_NEXT = _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_END_TARGET)
 
                	'空白に達したらループを抜ける
                	If strSTART_TARGET_CRNT = "" Or strSTART_TARGET_CRNT = "" Then
                    	GoTo CONT_FOR1
                	End If
 
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                	'この部分に具体的な処理を書いていく
 
                	' ① 範囲が完全一致　=　既に同じデータがあるので何もしない
                	If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                    	sOK = True
                    	eOK = True
                    	GoTo CONT_FOR1
                	End If
 
                	' ② 範囲が完全に含まれる 挿入×2 S2にS E2にE E1にS-1 S3にE+1
                    If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                    	sOK = True
                    	eOK = True
                    	' 挿入
                    	CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	' S2にS
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
                        ' E2にE
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    	' E1にS-1
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                    	' S3にE+1
                        _TBL_TARGER.Rows((idx_TARGET + 2)).Item(COL_START_TARGET) = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                    	' 処理終わり
                    	GoTo CONT_FOR1
                	End If
 
                	' ③　行を跨いで完全に含まれる
                	If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                    	sOK = True
                    	eOK = True
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	' S2にS
                    	_TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
                    	' E2にE
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    	' 処理終わり
          	          GoTo CONT_FOR1
                	End If
 
                	'■■■■開始（START）番号チェック■■■■■■■■■
 
                	'①strSTART_NEWRNG_CRNTとstrSTART_TARGET_CRNTが一致したら、
                	'　1行下に挿入
                	'　現行の終了にstrSTART_NEWRNG_CRNTに設定
                	'　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
                	If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                    	sOK = True
                    	' ただし現行終了(NEWRNG)が現行終了(TARGET)を超えていたら分割不要
                    	If (strEND_TARGET_CRNT < strEND_NEWRNG_CRNT) Then
                        	' 処理終わり
                        	GoTo TO_END1
                    	End If
                    	' 挿入
                    	CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　現行の終了にstrSTART_NEWRNG_CRNTに設定
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = strSTART_NEWRNG_CRNT
                    	'　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
                	    _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = Format(CLng(strSTART_NEWRNG_CRNT) + 1, "000000")
                    	' 処理終わり
                    	GoTo TO_END1
                	End If
 
                	'②strSTART_NEWRNG_CRNTとstrEND_TARGET_CRNTが一致
                	'　1行下に挿入
                	'　次行の開始にstrSTART_NEWRNG_CRNTセット
                	'　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
                	If (strSTART_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                    	sOK = True
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	' S2にSセット
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
           	         '　次行の開始にstrSTART_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                    	'　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
                    	GoTo TO_END1
                	End If
 
                	'③開始と終了に挟まれる場合 strSTART_TARGET_CRNT　＜ strSTART_NEWRNG_CRNT ＜ strEND_TARGET_CRNT
                	'　1行下に挿入
                	'　次行の開始にstrSTART_NEWRNG_CRNTセット
                	'　現業の終了に(strSTART_NEWRNG_CRNT - 1)
                	If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                    	sOK = True
                    	' 挿入
           	         CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　次行の開始にstrSTART_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
                    	'　現業の終了に(strSTART_NEWRNG_CRNT - 1)
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                    	' 処理終わり
                    	GoTo TO_END1
                	End If
 
                	'④ 現行の終了と次行の開始の間　strEND_TARGET_CRNT　＜　strSTART_NEWRNG_CRNT　＜ strSTART_TARGET_NEXT
                	'　1行下に挿入
                	'　次行の開始にstrSTART_NEWRNG_CRNTセット
                	'　次行の終了に(strSTART_TARGET_NEXT - 1)
              	  If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                    	sOK = True
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　次行の開始にstrSTART_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
                    	'　次行の終了に(strSTART_TARGET_NEXT - 1)
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_END_TARGET) = Format(CLng(strSTART_TARGET_NEXT) - 1, "000000")
                    	' 処理終わり
                    	GoTo TO_END1
                	End If
 
TO_END1:  '開始番号終了ラベル
 
                    '■■■■終了（END）番号チェック■■■■■■■■■
                	'①現行開始と一致
                	'　1行下に挿入
                	'　現行終了にstrEND_NEWRNG_CRNTセット
                	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                	If (strEND_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                    	eOK = True
                    	' ただし現行開始(TARGET)が現行開始(NEWRNG)を超えていたら分割不要
                    	If (strSTART_NEWRNG_CRNT < strSTART_TARGET_CRNT) Then
                        	' 処理終わり
                   	     GoTo CONT_FOR1
                    	End If
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　現行終了にstrEND_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                    	' 処理終わり
                    	GoTo CONT_FOR1
                	End If
 
                	'②現行終了と一致
                	'　1行下に挿入
                	'　次行の開始にstrEND_NEWRNG_CRNTセット
                	'　現行の終了に(strEND_NEWRNG_CRNT - 1)
                	If (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                    	eOK = True
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　次行の開始にstrEND_NEWRNG_CRNTセット
	                    _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = strEND_NEWRNG_CRNT
                    	'　現行の終了に(strEND_NEWRNG_CRNT - 1)
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = Format(CLng(strEND_NEWRNG_CRNT) - 1, "000000")
                    	' 処理終わり
                    	GoTo CONT_FOR1
                	End If
 
                	'③現行開始と現行終了の間
                	'　1行下に挿入
                	'　現行終了にstrEND_NEWRNG_CRNTセット
                	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                	If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                    	eOK = True
                    	' 挿入
                    	CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　現行終了にstrEND_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                    	_TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                    	' 処理終わり
                    	GoTo CONT_FOR1
                	End If
 
                	' ④現行終了と次行開始の間
                	'　1行下に挿入
                	'　現行終了にstrEND_NEWRNG_CRNTセット
                	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                	If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                        eOK = True
                    	' 挿入
                        CopyInsertDown(_TBL_TARGER, idx_TARGET)
                    	'　現行終了にstrEND_NEWRNG_CRNTセット
                        _TBL_TARGER.Rows((idx_TARGET)).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    	'　次行開始に(strEND_NEWRNG_CRNT + 1)
                        _TBL_TARGER.Rows((idx_TARGET + 1)).Item(COL_START_TARGET) = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                    	' 処理終わり
                 	   GoTo CONT_FOR1
                	End If
 
 
                	'この部分に具体的な処理を書いていく
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CONT_FOR2:
            	Next idx_TARGET
            	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            	'存在しない番号の処理は
            	'この部分に具体的な処理を書いていく
            	' 5 上記以外（値が見つからない） ■先頭挿入 S0にSセット E0にSX-1
            	If sOK = False Then
                    InsertEmptyData(_TBL_TARGER, 0)
                    _TBL_TARGER.Rows(0).Item(COL_END_TARGET) = Format(CLng(_TBL_TARGER.Rows(1).Item(COL_START_TARGET)) - 1, "000000")
                    _TBL_TARGER.Rows(0).Item(COL_START_TARGET) = strSTART_NEWRNG_CRNT
            	End If
 
            	' 5 上記以外（値が見つからない ■最下挿入 EXにEセット SXにEX+1
            	'
            	If eOK = False Then
                    InsertEmptyData(_TBL_TARGER)
                    _TBL_TARGER.Rows(_TBL_TARGER.Rows.Count - 1).Item(COL_END_TARGET) = strEND_NEWRNG_CRNT
                    _TBL_TARGER.Rows(_TBL_TARGER.Rows.Count - 1).Item(COL_START_TARGET) = Format(CLng(_TBL_TARGER.Rows((_TBL_TARGER.Rows.Count - 1)).Item(COL_END_TARGET)) + 1, "000000")
            	End If
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CONT_FOR1:
            Next idx_NEWRNG
 
        Catch ex As Exception
        Finally
            _TBL_NEWRNGE.AcceptChanges()
            _TBL_TARGER.AcceptChanges()
    	End Try
    End Sub

#Region "補助機能"
 
    ''' <summary>
    ''' 同じ内容の行を1個下の行に追加
    ''' </summary>
    ''' <param name="dtA"></param>
    ''' <param name="idx"></param>
    Public Sub CopyInsertDown(ByRef dtA As DataTable, ByVal idx As Double)
        Try
            Dim rwNew As DataRow
            rwNew = dtA.NewRow
            rwNew.ItemArray = dtA.Rows(idx).ItemArray
            dtA.Rows.InsertAt(rwNew, idx + 1)
        Catch ex As Exception
 
        End Try
    End Sub
 
    ''' <summary>
    ''' ~データを追加する
    ''' </summary>
    ''' <param name="dtA"></param>
    ''' <param name="idx"></param>
    Public Sub InsertEmptyData(ByRef dtA As DataTable, Optional ByVal idx As Double = -1)
        Try
            Dim rwNew As DataRow
            rwNew = dtA.NewRow
            If idx >= -1 Then
            	dtA.Rows.InsertAt(rwNew, idx)
            Else
            	dtA.ImportRow(rwNew)
            End If
        Catch ex As Exception
        End Try
    End Sub
 
    ''' <summary>
    ''' ソート対象のテーブル作成
    ''' DataTable自体にはソートをしてくれる機能がありませんが、DataTable.Select を応用することでソート処理ができます。
    ''' </summary>
    ''' <param name="tblTarget"></param>
    ''' <param name="sortText">"Age DESC , ID ASC"</param>
    ''' <returns></returns>
    Public Function SortDataTable(ByVal tblTarget As DataTable, ByVal sortText As String)
        'ソート後の DataTable を用意
        Dim dtblSrt As New DataTable()
        Try
            'ソート前テーブルの情報をクローン
            dtblSrt = tblTarget.Clone()
 
            'DataTable.Select()を使いソート(第二引数にソート条件を書く)
            Dim rows As DataRow() = tblTarget.Select(Nothing, sortText).Clone()
            'ソートされてる DataRow 配列をソート後の DataTable に追加
            For Each row As DataRow In rows
            	dtblSrt.ImportRow(row)
            Next
        Catch ex As Exception
        End Try
        Return dtblSrt
    End Function
 
    ''' <summary>
    ''' ###テストDataTable 作成###
    ''' </summary>
    ''' <param name="_TBL_NAME"></param>
    ''' <param name="dblMaxDataCnt"></param>
    ''' <param name="sPan"></param>
    ''' <returns></returns>
    Public Function CreateDataTable(ByVal _TBL_NAME As String, Optional ByVal dblMaxDataCnt As Double = 100, Optional ByVal sPan As Integer = 10) As DataTable
        Dim tbl As New DataTable(_TBL_NAME)
        tbl.Columns.Add("col1", Type.GetType("System.String"))
        tbl.Columns.Add("col2", Type.GetType("System.String"))
        tbl.Columns.Add("col3", Type.GetType("System.String"))
        tbl.Columns.Add("col4", Type.GetType("System.String"))
        tbl.Columns.Add("col5", Type.GetType("System.String"))
	    For i As Integer = 0 To dblMaxDataCnt
            Dim rwNew As DataRow
            rwNew = tbl.NewRow
            rwNew("col2") = (i + sPan).ToString("000000")
            rwNew("col3") = (i + sPan * 100).ToString("000000")
            tbl.Rows.Add(rwNew)
        Next
        tbl.AcceptChanges()
        Return tbl
    End Function
 
#End Region
 
End Class

2018-12-15

【VBA】データを分割（統合）ための極意【パターン化によるデータ分割】

かんたんだけどしっかりわかるExcelマクロ・VBA入門短時間で身につく忙しい人のためのエクセルの教科書 [ 古川順平 ]

ジャンル: 本・雑誌・コミック > PC・システム開発 > その他
ショップ: 楽天ブックス
価格: 2,138円

' 名称を明確に統一（変更しました。）
' TARGET:分割される側につける（接頭or接尾）
' NEWRNG:分割する側につける（接頭or接尾）
' CRNT:カレント行
' PREV:１個前の行
' NEXT:１個次の行

' ★.NET版に改良する予定-シートをDATAGridViewに置き換える予定。（課題：コピー＆行の挿入方法）' ★

' １個データごとに処理したらTrueになる
' 開始
Public sOK As Boolean
' 終了
Public eOK As Boolean

' 分割する側の列：NEWRNG
Const COL_START_NEWRNG = "A"
Const COL_END_NEWRNG = "B"

' 分割される側の列：TARGET
Const COL_START_TARGET = "B"
Const COL_END_TARGET = "C"

' ■テスト■用コールSUB
Public Sub Execute_For_Debug()
    Call SplitRowData(ThisWorkbook.Sheets("TARGET"), ThisWorkbook.Sheets("NEWR"))
End Sub

' @
' @
' @ wsTARGET:分割される側のシート
' @ wsNEWRNG:分割する側のシート
' @
Public Sub SplitRowData(ByRef WS_TARGET_ As Worksheet, ByRef WS_NEWRNG_ As Worksheet)
    ' 分割される側のシート
    Dim wsTARGET As Worksheet
    ' 分割する側のシート
    Dim wsNEWRNG As Worksheet

    ' 分割される側のインデックス
    Dim idx_TARGET As Long
    '分割する側のインデックス
    Dim idx_NEWRNG As Long
    'ワークシートの設定
    Set wsTARGET = WS_TARGET_
    Set wsNEWRNG = WS_NEWRNG_

    ' 分割する側(NEWRNG)のデータ側でループ
    For idx_NEWRNG = 1 To 10000
        DoEvents
        ' フラグ初期化
        sOK = False
        eOK = False

        'カレントデータを保存
        Dim strSTART_NEWRNG_CRNT As String
        Dim strEND_NEWRNG_CRNT As String

        '分割する側のデータを取得（カレント）
        strSTART_NEWRNG_CRNT = wsNEWRNG.Range(COL_START_NEWRNG & idx_NEWRNG).Text
        strEND_NEWRNG_CRNT = wsNEWRNG.Range(COL_END_NEWRNG & idx_NEWRNG).Text

        '分割する側が空白になったら終了
        If strEND_NEWRNG_CRNT = "" Or strSTART_NEWRNG_CRNT = "" Then
            Exit Sub
        End If

        ' 分割される側(TARGET)でループ
        For idx_TARGET = 1 To 10000
            DoEvents
            '一個前のデータ
            Dim strSTART_TARGET_PREV As String
            Dim strEND_TARGET_PREV As String
            'カレントデータ
            Dim strSTART_TARGET_CRNT As String
            Dim strEND_TARGET_CRNT As String
            '次のデータ
            Dim strSTART_TARGET_NEXT As String
            Dim strEND_TARGET_NEXT As String

            '一個前のデータを取得
            If idx_TARGET > 1 Then
                strSTART_TARGET_PREV = wsTARGET.Range(COL_START_TARGET & (idx_TARGET - 1)).Text
                strEND_TARGET_PREV = wsTARGET.Range(COL_END_TARGET & (idx_TARGET - 1)).Text
            End If

            'カレントデータ取得
            strSTART_TARGET_CRNT = wsTARGET.Range(COL_START_TARGET & idx_TARGET).Text
            strEND_TARGET_CRNT = wsTARGET.Range(COL_END_TARGET & idx_TARGET).Text
            '次の行のデータ
            strSTART_TARGET_NEXT = wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Text
            strEND_TARGET_NEXT = wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Text

            '空白に達したらループを抜ける
            If strSTART_TARGET_CRNT = "" Or strSTART_TARGET_CRNT = "" Then
                GoTo CONT_FOR1:
            End If

            '
            '   まず全体のチェックから始める
            '   ①   範囲が完全一致
            If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                sOK = True
                eOK = True
                GoTo CONT_FOR1
            End If

            '   ②  範囲が完全に含まれる 挿入×2 S2にS   E2にE   E1にS-1 S3にE+1
            If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                sOK = True
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                ' E2にE
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                ' E1にS-1
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                ' S3にE+1
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 2)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ③　行を跨いで完全に含まれる
            If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                sOK = True
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                ' E2にE
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            '
            '■■■■開始（START）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①strSTART_NEWRNG_CRNTとstrSTART_TARGET_CRNTが一致したら、
            '　1行下に挿入
            '　現行の終了にstrSTART_NEWRNG_CRNTに設定
            '　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
            If (strSTART_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                sOK = True
                ' ただし現行終了(NEWRNG)が現行終了(TARGET)を超えていたら分割不要
                If (strEND_TARGET_CRNT < strEND_NEWRNG_CRNT) Then
                    ' 処理終わり
                    GoTo TO_END1
                End If
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行の終了にstrSTART_NEWRNG_CRNTに設定
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strSTART_NEWRNG_CRNT
                '　次行の開始に(strSTART_NEWRNG_CRNT + 1)を設定
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strSTART_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '②strSTART_NEWRNG_CRNTとstrEND_TARGET_CRNTが一致
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
            If (strSTART_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にSセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                '　現業の終了に(strSTART_NEWRNG_CRNT - 1)セット
                GoTo TO_END1
            End If
            '③開始と終了に挟まれる場合 strSTART_TARGET_CRNT　＜  strSTART_NEWRNG_CRNT ＜  strEND_TARGET_CRNT
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　現業の終了に(strSTART_NEWRNG_CRNT - 1)
            If (strSTART_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　現業の終了に(strSTART_NEWRNG_CRNT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strSTART_NEWRNG_CRNT) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '④   現行の終了と次行の開始の間　strEND_TARGET_CRNT　＜　strSTART_NEWRNG_CRNT　＜ strSTART_TARGET_NEXT
            '　1行下に挿入
            '　次行の開始にstrSTART_NEWRNG_CRNTセット
            '　次行の終了に(strSTART_TARGET_NEXT - 1)
            If (strSTART_NEWRNG_CRNT > strEND_TARGET_CRNT) And (strSTART_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                sOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrSTART_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strSTART_NEWRNG_CRNT
                '　次行の終了に(strSTART_TARGET_NEXT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strSTART_TARGET_NEXT) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If

TO_END1:

            '■■■■終了（END）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①現行開始と一致
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT = strSTART_TARGET_CRNT) Then
                eOK = True
                ' ただし現行開始(TARGET)が現行開始(NEWRNG)を超えていたら分割不要
                If (strSTART_NEWRNG_CRNT < strSTART_TARGET_CRNT) Then
                    ' 処理終わり
                    GoTo CONT_FOR1
                End If
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '②現行終了と一致
            '　1行下に挿入
            '　次行の開始にstrEND_NEWRNG_CRNTセット
            '　現行の終了に(strEND_NEWRNG_CRNT - 1)
            If (strEND_NEWRNG_CRNT = strEND_TARGET_CRNT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　次行の開始にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = strEND_NEWRNG_CRNT
                '　現行の終了に(strEND_NEWRNG_CRNT - 1)
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = Format(CLng(strEND_NEWRNG_CRNT) - 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '③現行開始と現行終了の間
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strEND_TARGET_CRNT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ④現行終了と次行開始の間
            '　1行下に挿入
            '　現行終了にstrEND_NEWRNG_CRNTセット
            '　次行開始に(strEND_NEWRNG_CRNT + 1)
            If (strEND_NEWRNG_CRNT > strSTART_TARGET_CRNT) And (strEND_NEWRNG_CRNT < strSTART_TARGET_NEXT) Then
                eOK = True
                ' 挿入
                wsTARGET.Activate
                wsTARGET.Rows(idx_TARGET & ":" & idx_TARGET).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                '　現行終了にstrEND_NEWRNG_CRNTセット
                wsTARGET.Range(COL_END_TARGET & (idx_TARGET)).Value = strEND_NEWRNG_CRNT
                '　次行開始に(strEND_NEWRNG_CRNT + 1)
                wsTARGET.Range(COL_START_TARGET & (idx_TARGET + 1)).Value = Format(CLng(strEND_NEWRNG_CRNT) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
CONT_FOR2:
        Next idx_TARGET

        '   5   上記以外（値が見つからない）  ■先頭挿入    S0にSセット E0にSX-1
        If sOK = False Then
            wsTARGET.Activate
            wsTARGET.Rows("1:1").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsTARGET.Range(COL_END_TARGET & (1)).Value = Format(CLng(wsTARGET.Range(COL_START_TARGET & (2)).Text) - 1, "000000")
            wsTARGET.Range(COL_START_TARGET & (1)).Value = strSTART_NEWRNG_CRNT
        End If

        '   5   上記以外（値が見つからない   ■最下挿入    EXにEセット SXにEX+1
        '
        If eOK = False Then
            wsTARGET.Activate
            Dim rowLast As Long
            rowLast = wsTARGET.UsedRange.Row
            wsTARGET.Rows(rowLast & ":" & rowLast).Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsTARGET.Range(COL_END_TARGET & (rowLast + 1)).Value = strEND_NEWRNG_CRNT
            wsTARGET.Range(COL_START_TARGET & (rowLast + 1)).Value = Format(CLng(wsTARGET.Range(COL_END_TARGET & (rowLast - 1)).Text) + 1, "000000")
        End If

CONT_FOR1:
    Next idx_NEWRNG

End Sub

はじめての簡単 Excel VBA［決定版］　（Windows8/Excel2013完全対応）【電子書籍】[ 金城俊哉 ]

2018-12-14

【エクセルVBA】範囲（枠）を別範囲（枠）で分割するアルゴリズム

Windows 10 Home 日本語版（Fall Creators Update 適用済）マイクロソフト ※パッケージ（USBメディア）版

ジャンル: パソコン・周辺機器 > ソフトウェア > OS（オペレーティングシステム） > Windows
ショップ: Joshin web 家電とPCの大型専門店
価格: 17,070円

Public sOK As Boolean
Public eOK As Boolean

' 分割する側
Const COL_START_DATA = "A"
Const COL_END_DATA = "B"

' 分割される側
Const COL_START_ORG = "B"
Const COL_END_ORG = "C"

Public Sub SplitRowData()
    ' 分割される側のシート
    Dim wsORG As Worksheet
    ' 分割する側のシート
    Dim wsDATA As Worksheet

    ' 分割される側のインデックス
    Dim iOrg As Long
    '分割する側のインデックス
    Dim iData As Long
    'ワークシートの設定
    Set wsORG = ThisWorkbook.Sheets("ORIGINAL")
    Set wsDATA = ThisWorkbook.Sheets("NDATA")

    ' 分割する側のデータ側でループ
    For iData = 1 To 10000
        DoEvents
        ' フラグ初期化
        sOK = False
        eOK = False

        'カレントデータを保存
        Dim sData As String
        Dim eData As String

        '分割する側のデータを取得（カレント）
        sData = wsDATA.Range(COL_START_DATA & iData).Text
        eData = wsDATA.Range(COL_END_DATA & iData).Text

        '分割する側が空白になったら終了
        If eData = "" Or sData = "" Then
            Exit Sub
        End If

        ' オリジナルデータ側でループ
        For iOrg = 1 To 10000
            DoEvents
            '一個前のデータ
            Dim sOrg_PREV As String
            Dim eOrg_PREV As String
            'カレントデータ
            Dim sOrg As String
            Dim eOrg As String
            '次のデータ
            Dim sOrg_NEXT As String
            Dim eOrg_NEXT As String

            '一個前のデータを取得
            If iOrg > 1 Then
                sOrg_PREV = wsORG.Range(COL_START_ORG & (iOrg - 1)).Text
                eOrg_PREV = wsORG.Range(COL_END_ORG & (iOrg - 1)).Text
            End If

            'カレントデータ取得
            sOrg = wsORG.Range(COL_START_ORG & iOrg).Text
            eOrg = wsORG.Range(COL_END_ORG & iOrg).Text
            '次の行のデータ
            sOrg_NEXT = wsORG.Range(COL_START_ORG & (iOrg + 1)).Text
            eOrg_NEXT = wsORG.Range(COL_END_ORG & (iOrg + 1)).Text

            '空白に達したらループを抜ける
            If sOrg = "" Or sOrg = "" Then
                GoTo CONT_FOR1:
            End If

            '
            '   まず全体のチェックから始める
            '   ①   範囲が完全一致
            If (sData = sOrg) And (eData = eOrg) Then
                sOK = True
                eOK = True
                GoTo CONT_FOR1
            End If

            '   ②  範囲が完全に含まれる 挿入×2 S2にS   E2にE   E1にS-1 S3にE+1
            If (sData > sOrg) And (eData < eOrg) Then
                sOK = True
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData
                ' E2にE
                wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = eData
                ' E1にS-1
                wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000")
                ' S3にE+1
                wsORG.Range(COL_START_ORG & (iOrg + 2)).Value = Format(CLng(eData) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ③　行を跨いで完全に含まれる
            If (sData > eOrg) And (eData < sOrg_NEXT) Then
                sOK = True
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にS
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData
                ' E2にE
                wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = eData
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            '
            '■■■■開始（START）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①sDataとsOrgが一致したら、
            '　1行下に挿入
            '　現行の終了にsDataに設定
            '　次行の開始に(sData + 1)を設定
            If (sData = sOrg) Then
                sOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' E1にSセット
                wsORG.Range(COL_END_ORG & (iOrg)).Value = sData
                ' S2にS+1
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(sData) + 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '②sDataとeOrgが一致
            '　1行下に挿入
            '　次行の開始にsDataセット
            '　現業の終了に(sData - 1)セット
            If (sData = eOrg) Then
                sOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にSセット
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData
                ' E1にS-1
                wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '③開始と終了に挟まれる場合 sOrg　＜  sData ＜  eOrg
            '　1行下に挿入
            '　次行の開始にsDataセット
            '　現業の終了に(sData - 1)
            If (sData > sOrg) And (sData < eOrg) Then
                sOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にSセット
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData
                ' E1にS-1
                wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(sData) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If
            '④   現行の終了と次行の開始の間　eOrg　＜　sData　＜ sOrg_NEXT
            '　1行下に挿入
            '　次行の開始にsDataセット
            '　次行の終了に(sData_NEX - 1)
            If (sData > eOrg) And (sData < sOrg_NEXT) Then
                sOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にSセット
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = sData
                ' E2にS3-1
                wsORG.Range(COL_END_ORG & (iOrg + 1)).Value = Format(CLng(sData_NEX) - 1, "000000")
                ' 処理終わり
                GoTo TO_END1
            End If

TO_END1:

            '■■■■終了（END）番号チェック■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
            '①現行開始と一致
            '　1行下に挿入
            '　現行終了にeDataセット
            '　次行開始に(eData + 1)
            If (eData = sOrg) Then
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' E1にEセット
                wsORG.Range(COL_END_ORG & (iOrg)).Value = eData
                ' S2にE+1
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '②現行終了と一致
            '　1行下に挿入
            '　次行の開始にeDataセット
            '　現行の終了に(eData - 1)
            If (eData = eOrg) Then
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' S2にEセット
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = eData
                ' E1にE-1
                wsORG.Range(COL_END_ORG & (iOrg)).Value = Format(CLng(eData) - 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
            '③現行開始と現行終了の間
            '　1行下に挿入
            '　現行終了にeDataセット
            '　次行開始に(eData + 1)
            If (eData > sOrg) And (eData < eOrg) Then
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' E1にEセット
                wsORG.Range(COL_END_ORG & (iOrg)).Value = eData
                ' S2にE+1
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If

            ' ④現行終了と次行開始の間
            '　1行下に挿入
            '　現行終了にeDataセット
            '　次行開始に(eData + 1)
            If (eData > sOrg) And (eData < sOrg_NEXT) Then
                eOK = True
                ' 挿入
                wsORG.Activate
                wsORG.Rows(iOrg & ":" & iOrg).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Selection.Interior.Color = vbRed
                ' E1にEセット
                wsORG.Range(COL_END_ORG & (iOrg)).Value = eData
                ' S2にE+1
                wsORG.Range(COL_START_ORG & (iOrg + 1)).Value = Format(CLng(eData) + 1, "000000")
                ' 処理終わり
                GoTo CONT_FOR1
            End If
CONT_FOR2:
        Next iOrg

        '   5   上記以外（値が見つからない）  ■先頭挿入    S0にSセット E0にSX-1
        If sOK = False Then
            wsORG.Activate
            wsORG.Rows("1:1").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsORG.Range(COL_END_ORG & (1)).Value = Format(CLng(wsORG.Range(COL_START_ORG & (2)).Text) - 1, "000000")
            wsORG.Range(COL_START_ORG & (1)).Value = sData
        End If

        '   5   上記以外（値が見つからない   ■最下挿入    EXにEセット SXにEX+1
        '
        If eOK = False Then
            wsORG.Activate
            Dim rowLast As Long
            rowLast = wsORG.UsedRange.Row
            wsORG.Rows(rowLast & ":" & rowLast).Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Selection.Interior.Color = vbRed
            wsORG.Range(COL_END_ORG & (rowLast + 1)).Value = eData
            wsORG.Range(COL_START_ORG & (rowLast + 1)).Value = Format(CLng(wsORG.Range(COL_END_ORG & (rowLast - 1)).Text) + 1, "000000")
        End If

CONT_FOR1:
    Next iData

End Sub

Windows 10 Home 64bit Jpn DSP DVD 【LANボードセット限定】 JP9PNC

ジャンル: パソコン・周辺機器 > ソフトウェア > OS（オペレーティングシステム） > Windows
ショップ: パソコンパーツのアプライド
価格: 13,980円

2018-12-04

VLOOKUPを利用する場合にTRUE(近似一致)、FALSE(完全一致)で結果はどのように変わるのか検証

Excelピボットテーブルデータ集計・分析の「引き出し」が増える本 [ 木村幸子 ]

ジャンル: 本・雑誌・コミック > PC・システム開発 > その他
ショップ: 楽天ブックス
価格: 2,462円

数値の場合

検索範囲が「昇順である」の場合（昇順に並び替えておかないと正確に検索できない）

Excel VLOOKUP の「TRUE(近似一致)」または「FALSE(完全一致)」で、挙動がどのように変わるのか確認。

■前提条件

正確にVLOOKUPを使用するために必要なこと。
1. ①検索範囲が「昇順」でなければならない
2. ②数値と文字列が混ざる場合は、文字列に統一すること

■「検索条件」の省略について

【カンマ有で省略】
1. = VLOOKUP (検索値, 検索範囲, 戻り値の列番号, ) ⇒「FALSE(完全一致)」となる(省略していないとみなされる)
【カンマ無で省略】
1. = VLOOKUP (検索値, 検索範囲, 戻り値の列番号) ⇒ 「TRUE(近似一致)」となる(省略しているとみなされる)

違うのは最後の「,　(コンマ)」を付けるか付けないかです。
1. ※「, (カンマ)」があることで、省略していないとみなされ、空白値「0(ゼロ)」（FALSE(完全一致)）があるとみなされます。

検索範囲が「昇順である」の場合

元データ1

A	B
1	値1
2	値2
3	値3

TRUE(近似一致)

数値	値
1	値1
1.1	値1
1.2	値1
1.3	値1
1.4	値1
1.5	値1
1.6	値1
1.7	値1
1.8	値1
1.9	値1
2	値2
2.1	値2
2.2	値2
2.3	値2
2.4	値2
2.5	値2
2.6	値2
2.7	値2
2.8	値2
2.9	値2
3	値3

FALSE(完全一致)

数値	値
1	値1
1.1	#N/A
1.2	#N/A
1.3	#N/A
1.4	#N/A
1.5	#N/A
1.6	#N/A
1.7	#N/A
1.8	#N/A
1.9	#N/A
2	値2
2.1	#N/A
2.2	#N/A
2.3	#N/A
2.4	#N/A
2.5	#N/A
2.6	#N/A
2.7	#N/A
2.8	#N/A
2.9	#N/A
3	値3

検索範囲が「昇順でない」の場合

元データ2

A	B
3	値3
2	値2
1	値1

TRUE(近似一致)

数値	値
1	#N/A
1.1	#N/A
1.2	#N/A
1.3	#N/A
1.4	#N/A
1.5	#N/A
1.6	#N/A
1.7	#N/A
1.8	#N/A
1.9	#N/A
2	値2
2.1	値1
2.2	値1
2.3	値1
2.4	値1
2.5	値1
2.6	値1
2.7	値1
2.8	値1
2.9	値1
3	値1

FALSE(完全一致)

数値	値
1	値1
1.1	#N/A
1.2	#N/A
1.3	#N/A
1.4	#N/A
1.5	#N/A
1.6	#N/A
1.7	#N/A
1.8	#N/A
1.9	#N/A
2	値2
2.1	#N/A
2.2	#N/A
2.3	#N/A
2.4	#N/A
2.5	#N/A
2.6	#N/A
2.7	#N/A
2.8	#N/A
2.9	#N/A
3	値3

VLOOKUP関数は、検索範囲が昇順(小さい順)にきちんと並んでいないと、不可解な、意味のない結果を返す。

※これは二分探索(バイナリサーチ)というアルゴリズムを利用しているためである。

VLOOKUPで、数値データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）検索値を超えない範囲の最大値を返す。

検索範囲が昇順でない場合は、確実な動作が得られない。

正確に動作させるには、念のため、検索範囲の方を昇順で並べ替えておくとよいでしょう。

また、「検索値を超えない範囲の最大値」を戻り値とするため、実際上は「切り捨て」と同様の意味になります。もしこれを「四捨五入」にしたい場合には、

'=VLOOKUP(ROUND(A2),検索範囲,2,TRUE)

のように、あらかじめ検索値を四捨五入しておくとよいでしょう。

[ポイント最大23倍]マイクロソフトエクセル 2016 Microsoft Office Excel for Windows 1ユーザー2台用オフィス単体ソフト永続ライセンスカード版【Windows用】

ジャンル: パソコン・周辺機器 > ソフトウェア > ビジネス・オフィス用 > 表計算・グラフ
ショップ: バリューマックス
価格: 23,980円

文字列の場合

元データ３

A	B
1ばん	1
1ばんめ2	1.5
1ばんめ3	1.8
2ばんめ1	2
2ばんめ2	2.2
2ばんめ大	2.9
3ばん1	3
3ばんめ2	3.3
3ばんめ９	3.6

TRUE(近似一致)

数値	値
1ばん	1
1ばんめ1	1
1ばんめ22	1.5
9ばんめ9	3.6
漢字	3.6
2番目	2.9
1	#N/A
2	#N/A
3	#N/A
1ばん	1
2ばん	1.8
3番	3.6
3ばん	2.9
2ばんめ大	2.9
1ばん	1
1ばんめ2	1.5
1ばんめ3	1.8
2ばんめ1	2
2ばんめ2	2.2
2ばんめ大	2.9
3ばん1	3

FALSE(完全一致)

数値	値
1ばん	1
1ばんめ1	#N/A
1ばんめ22	#N/A
1ばんめ9	#N/A
漢字	#N/A
2番目	#N/A
1	#N/A
2	#N/A
3	#N/A
1ばん	1
2ばん	#N/A
3番	#N/A
3ばん	#N/A
2ばんめ大	2.9
1ばん	1
1ばんめ2	1.5
1ばんめ3	1.8
2ばんめ1	2
2ばんめ2	2.2
2ばんめ大	2.9
3ばん1	3

VLOOKUPで、文字データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）

文字列に対してVLOOKUPを使用した場合、近似値で検索すると「前方一致」となる。

近似一致の結果は、前方一致のよう

「検索値→範囲」　ではなく、「範囲の各値→検索値」の前方一致

複数が一致する場合はできるだけ多くの文字が一致するものが返っている

Excel 最強の教科書[完全版]――すぐに使えて、一生役立つ「成果を生み出す」超エクセル仕事術

作者: 藤井直弥,大山啓介
出版社/メーカー: SBクリエイティブ
発売日: 2017/01/28
メディア: 単行本
この商品を含むブログ (2件) を見る

2018-12-03

古紙や無地の新聞紙、新聞用の用紙を手に入れる方法

台風・地震と日本列島が災害に見舞われる中、携帯トイレや防寒用、スリッパなどに新聞紙を活用するライフハックが注目されています。しかし、日本新聞協会の調査によると2017年の新聞発行部数は4212万8189部となっていて、10年間で900万部以上落ち込んでおり、新聞紙のストックがない家庭が多い現状が見て取れます。

発売されています。
「学校行事に使える」「引っ越しの時にも役立ちそう」「靴が濡れたときに欲しい」という反応が続々と寄せられていた一方で、「窓拭きには印刷済の方がコスパが良い計算になります。
「高い……」と感じる人も多かった模様ですが、「新聞屋で無料でもらえる」といった意見も。
梱包用の新聞紙は新聞屋でタダで貰えますよ。

新聞紙詰め物更紙ペットシーツ梱包材 10kg ペットトイレシート中敷き・荷造りの緩衝材等人気お得！

出版社/メーカー: Kkoubo
メディア: ホーム&キッチン
この商品を含むブログを見る

新品の新聞紙ペットシーツ更紙梱包材お試し20枚 or 100枚ペットトイレシート中敷き・荷造りの緩衝材等人気お得！ (お試し100枚)

出版社/メーカー: Kkoubo
メディア: その他
この商品を含むブログを見る

隙間埋め紙緩衝材（ザラ紙・更紙）　７８８×５４５ｍｍ　【１０００枚】　自分で丸める紙緩衝材

出版社/メーカー: 梱包資材のぷちぷちや
メディア:
この商品を含むブログを見る

新聞紙おためしセット(Mサイズ3枚+Lサイズ3枚)

出版社/メーカー: K-MART
メディア: その他
この商品を含むブログを見る

アーテック新聞レイアウト用紙 A3(50枚) 3438

出版社/メーカー: アーテック
メディア: Tools & Hardware
この商品を含むブログを見る

2018-12-01

EnumWindowsでウィンドウとコントロールの全ての情報を取得するモジュール：FindWindowExなどでうまく取得できないコントロールがある場合の最終手段

Windows 10 Home 日本語版（Fall Creators Update 適用済）マイクロソフト ※パッケージ（USBメディア）版

ジャンル: パソコン・周辺機器 > ソフトウェア > OS（オペレーティングシステム） > Windows
ショップ: Joshin web 家電とPCの大型専門店
価格: 17,070円

【対象】VB.NET
まずは、以下のようにModEnumWinモジュールを作成します。

''' <summary>
''' EnumWindows利用方法
''' 全てのウィンドウ情報を取得する
''' </summary>
Module ModEnumWin
	' APIの定義
	Private Const WM_GETTEXT = &HD
	Private Delegate Function D_EnumWindowsProc(
    	ByVal hWnd As Integer, ByVal lParam As Integer) As Integer
	Private Delegate Function D_EnumChildWindowsProc(
    	ByVal hWnd As Integer, ByVal lParam As Integer) As Integer
	Private Declare Function EnumWindows Lib "user32.dll" _
    	(ByVal lpEnumFunc As D_EnumWindowsProc, ByVal lParam As Integer) As Integer
	Private Declare Function EnumChildWindows Lib "user32.dll" _
    	(ByVal hwndParent As Integer, ByVal lpEnumFunc As D_EnumChildWindowsProc,
     	ByVal lParam As Integer) As Integer
	Private Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" _
    	(ByVal hWnd As Integer, ByVal lpClassName As Byte(),
     	ByVal nMaxCount As Integer) As Integer
	Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
    	(ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer,
     	ByVal lParam As Byte()) As Integer
 
	' コントロール毎の情報を設定するコレクション
	Private colWindows As New Collection
 
	' ウィンドウとコントロールを全て取得
	Public Function GetAllWindows() As Collection
    	On Error Resume Next
    	Dim i As Long
    	Dim lngRet As Long
 
    	' コントロール毎の情報を設定するコレクション生成
    	colWindows = New Collection
    	GetAllWindows = colWindows
 
    	' トップレベルウィンドウを全て取得
    	lngRet = EnumWindows(AddressOf EnumWindowsProc, 0)
 
    	' 親ウィンドウに属するコントロールを全て取得
    	For i = 1 To colWindows.Count
        	lngRet = EnumChildWindows(
            	colWindows.Item(i).Item(1)(0), AddressOf EnumChildWindowsProc, i)
    	Next i
	End Function
 
	' トップレベルウィンドウを全て取得
	Public Function EnumWindowsProc(
    	ByVal hWnd As Integer, ByVal lParam As Integer) As Integer
    	On Error Resume Next
    	Dim lngRet As Long
    	Dim bytClass As Byte() = New Byte(255) {}
    	Dim bytTitle As Byte() = New Byte(255) {}
    	Dim strClass As String
    	Dim strTitle As String
 
    	' クラス名取得
    	lngRet = GetClassName(hWnd, bytClass, 255)
    	strClass = StripNulls(bytClass)
 
    	' ウィンドウのタイトル取得
    	lngRet = SendMessage(hWnd, WM_GETTEXT, 255, bytTitle)
    	strTitle = StripNulls(bytTitle)
 
    	' 取得した情報を配列に設定
    	Dim strDa(2) As Object
    	strDa(0) = hWnd
    	strDa(1) = strClass
    	strDa(2) = strTitle
 
    	' 取得した情報をコレクションに設定
    	Dim colDa As New Collection
    	colDa.Add(strDa)
 
    	' トップレベルウィンドウ毎のコレクションに追加
    	colWindows.Add(colDa)
 
    	' リターン
    	EnumWindowsProc = 1
	End Function
 
	' 指定された親ウィンドウに属するコントロールを全て取得
	Private Function EnumChildWindowsProc(
    	ByVal hWnd As Integer, ByVal lParam As Integer) As Integer
    	On Error Resume Next
    	Dim lngRet As Long
    	Dim bytClass As Byte() = New Byte(255) {}
    	Dim bytTitle As Byte() = New Byte(255) {}
    	Dim strClass As String
    	Dim strTitle As String
 
    	' クラス名取得
    	lngRet = GetClassName(hWnd, bytClass, 255)
    	strClass = StripNulls(bytClass)
 
    	' ウィンドウのタイトル取得
    	lngRet = SendMessage(hWnd, WM_GETTEXT, 255, bytTitle)
    	strTitle = StripNulls(bytTitle)
 
    	' 取得した情報を配列に設定
    	Dim strDa(2) As Object
    	strDa(0) = hWnd
    	strDa(1) = strClass
    	strDa(2) = strTitle
 
    	' コントロール毎のコレクションに追加
    	colWindows.Item(lParam).Add(strDa)
 
    	' リターン
    	EnumChildWindowsProc = 1
	End Function
 
	' 文字列からＮＵＬＬ文字以降をカット
	Private Function StripNulls(ByVal bytOrg As Byte()) As String
    	On Error Resume Next
    	Dim strOrg As String =
        	System.Text.Encoding.GetEncoding("SHIFT-JIS").GetString(bytOrg)
    	If (InStr(strOrg, Chr(0)) > 0) Then
        	strOrg = Left(strOrg, InStr(strOrg, Chr(0)) - 1)
    	End If
    	StripNulls = strOrg
	End Function
End Module

【送料無料】マイクロソフト　Microsoft 〔USBメモリ〕 Windows 10 Pro 日本語版 FQC-10185 [Windows用]

ジャンル: パソコン・周辺機器 > ソフトウェア > OS（オペレーティングシステム） > Windows
ショップ: 楽天ビック
価格: 24,921円

【実際に呼び出す方法】
・例）フォームにTreeViewを配置してください。TreeViewの名称はTreeView1にします。
フォームにボタンなどを配置して、以下のExecuteEnumWinを呼び出します。
TreeViewに起動中のすべてのウィンドウとコントロールが表示されます。

[ポイント最大23倍]Microsoft Office 365 Solo マイクロソフトオフィス 2016 パッケージ版 1ユーザー2台用 1年版ライセンス【Windows/Mac用】

ジャンル: パソコン・周辺機器 > ソフトウェア > ビジネス・オフィス用 > 統合ソフト
ショップ: バリューマックス
価格: 19,980円

	''' <summary>
	''' 【呼出し】実行処理
	''' </summary>
	Public Sub ExecuteEnumWin()
    	Dim i As Long
    	Dim j As Long
    	Dim bytClass As Byte()
    	Dim bytTitle As Byte()
    	Dim bytSpace As Byte()
 
    	' ウィンドウとコントロールの全ての情報を取得
    	Dim colWindows As Collection
    	colWindows = GetAllWindows()
 
    	' 親ウィンドウ毎のコレクションループ
    	For i = 1 To colWindows.Count
        	' 子コントロール毎のコレクション取得
        	Dim colChilds As Collection
        	colChilds = colWindows.Item(i)
 
        	'If colChilds.Count >= 1 Then   	' 全ての親ウィンドウを対象
        	If colChilds.Count > 1 Then     	' 子コントロールを持つ物のみ対象
            	' 子コントロール毎のコレクションループ
            	Dim treeNodeTop As TreeNode = Nothing
            	For j = 1 To colChilds.Count
                	bytSpace = System.Text.Encoding.GetEncoding(
                    	"SHIFT-JIS").GetBytes(New String(" ", 50))
 
                	' コレクションからクラス名取得
                	bytClass = System.Text.Encoding.GetEncoding(
                    	"SHIFT-JIS").GetBytes(colChilds.Item(j)(1))
                	If bytClass.Length < 30 Then
                    	Dim p As Integer = bytClass.Length
                    	ReDim Preserve bytClass(bytClass.Length + bytSpace.Length - 1)
                    	Array.Copy(bytSpace, 0, bytClass, p, bytSpace.Length)
                    	ReDim Preserve bytClass(30 - 1)
                	End If
    	            Dim strClass As String = System.Text.Encoding.GetEncoding(
                    	"SHIFT-JIS").GetString(bytClass)
 
                	' コレクションから文字列取得
                	bytTitle = System.Text.Encoding.GetEncoding(
                    	"SHIFT-JIS").GetBytes(colChilds.Item(j)(2))
                	If bytTitle.Length < 50 Then
                    	Dim p As Integer = bytTitle.Length
                    	ReDim Preserve bytTitle(bytTitle.Length + bytSpace.Length - 1)
               	     Array.Copy(bytSpace, 0, bytTitle, p, bytSpace.Length)
                    	ReDim Preserve bytTitle(50 - 1)
                	End If
                	Dim strTitle As String = System.Text.Encoding.GetEncoding(
                    	"SHIFT-JIS").GetString(bytTitle)
 
                	If j = 1 Then
                    	' 親ウィンドウの情報をツリービューへ追加
                    	treeNodeTop = New TreeNode(strClass & " - " & strTitle)
                        TreeView1.Nodes.Add(treeNodeTop)
            	    Else
                    	' 子コントロールの情報をツリービューへ追加
                    	Dim treeNodeSub As TreeNode =
                        	New TreeNode(strClass & " - " & strTitle)
                        treeNodeTop.Nodes.Add(treeNodeSub)
             	   End If
            	Next j
        	End If
    	Next i
	End Sub

USB 2.0 3.5インチフロッピーディスクドライブ USB 外付けフロッピードライブ FDD パソコン読み込み周辺機器アクセサリー Windows Mac ◇USB-FDD【メール便】

ジャンル: パソコン・周辺機器 > パソコン周辺機器 > その他記憶装置（外付け） > フロッピーディスクドライブ
ショップ: 直販ワールドマーケット
価格: 1,480円

[VBA,VB.NET,C#,PHP]プログラムTips集

[VBA,VB.NET,C#,PHP]プログラムのちょっとしたテクニック

枠（FromとTo）から作成されているデータを分割するための基本アルゴリズム

枠の分割を行うアルゴリズムVB.NET

【VBA】データを分割（統合）ための極意【パターン化によるデータ分割】

【エクセルVBA】範囲（枠）を別範囲（枠）で分割するアルゴリズム

VLOOKUPを利用する場合にTRUE(近似一致)、FALSE(完全一致)で結果はどのように変わるのか検証

数値の場合

検索範囲が「昇順である」の場合（昇順に並び替えておかないと正確に検索できない）

■前提条件

■「検索条件」の省略について

検索範囲が「昇順である」の場合

元データ1

TRUE(近似一致)

FALSE(完全一致)

検索範囲が「昇順でない」の場合

元データ2

TRUE(近似一致)

FALSE(完全一致)

VLOOKUP関数は、検索範囲が昇順(小さい順)にきちんと並んでいないと、不可解な、意味のない結果を返す。

※これは二分探索(バイナリサーチ)というアルゴリズムを利用しているためである。

VLOOKUPで、数値データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）検索値を超えない範囲の最大値を返す。

検索範囲が昇順でない場合は、確実な動作が得られない。

正確に動作させるには、念のため、検索範囲の方を昇順で並べ替えておくとよいでしょう。

また、「検索値を超えない範囲の最大値」を戻り値とするため、実際上は「切り捨て」と同様の意味になります。もしこれを「四捨五入」にしたい場合には、

'=VLOOKUP(ROUND(A2),検索範囲,2,TRUE)

のように、あらかじめ検索値を四捨五入しておくとよいでしょう。

文字列の場合

元データ３

TRUE(近似一致)

FALSE(完全一致)

VLOOKUPで、文字データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）

文字列に対してVLOOKUPを使用した場合、近似値で検索すると「前方一致」となる。

近似一致の結果は、前方一致のよう

「検索値→範囲」　ではなく、「範囲の各値→検索値」の前方一致

複数が一致する場合はできるだけ多くの文字が一致するものが返っている

古紙や無地の新聞紙、新聞用の用紙を手に入れる方法

EnumWindowsでウィンドウとコントロールの全ての情報を取得するモジュール：FindWindowExなどでうまく取得できないコントロールがある場合の最終手段

数値の場合

検索範囲が「昇順である」の場合（昇順に並び替えておかないと正確に検索できない）

■前提条件

■「検索条件」の省略について

検索範囲が「昇順である」の場合

元データ1

TRUE(近似一致)

FALSE(完全一致)

検索範囲が「昇順でない」の場合

元データ2

TRUE(近似一致)

FALSE(完全一致)

VLOOKUP関数は、検索範囲が昇順(小さい順)にきちんと並んでいないと、不可解な、意味のない結果を返す。

※これは二分探索(バイナリサーチ)というアルゴリズムを利用しているためである。

VLOOKUPで、数値データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）検索値を超えない範囲の最大値を返す。

検索範囲が昇順でない場合は、確実な動作が得られない。

正確に動作させるには、念のため、検索範囲の方を昇順で並べ替えておくとよいでしょう。

また、「検索値を超えない範囲の最大値」を戻り値とするため、実際上は「切り捨て」と同様の意味になります。もしこれを「四捨五入」にしたい場合には、

'=VLOOKUP(ROUND(A2),検索範囲,2,TRUE)

のように、あらかじめ検索値を四捨五入しておくとよいでしょう。

文字列の場合

元データ３

TRUE(近似一致)

FALSE(完全一致)

VLOOKUPで、文字データを「近似一致」で検索した場合

（検索範囲を正確に昇順に整列した条件のもとで、）

文字列に対してVLOOKUPを使用した場合、近似値で検索すると「前方一致」となる。

近似一致の結果は、前方一致のよう

「検索値→範囲」 ではなく、「範囲の各値→検索値」の前方一致

複数が一致する場合はできるだけ多くの文字が一致するものが返っている

「検索値→範囲」　ではなく、「範囲の各値→検索値」の前方一致