425 B

いつの間にかVBAをはじめて，かなりの期間が経過した．
いつからはじめたのか覚えていませんが．

以下プログラムサンプルだが，中身は検索ルーチンの自作．
27進数の10進数化が…
ひいいいいっ！て感じ．



'配列の開始番号を1からに設定
Option Base 1

Public Sub PERFORM4()

Application.ScreenUpdating = False

'①ユーザーフォームから比較検索・入力列を取得
Dim sTIME As Date
Dim eTIME As Date
Dim TOTAL_TIME As Integer
Dim MASTER_ROW1 As String
Dim MASTER_ROW2 As String
Dim MASTER_ROW3 As String
Dim LOOKUP_ROW1 As String
Dim LOOKUP_ROW2 As String
Dim LOOKUP_ROW3 As String
Dim MASTER_SHEET As String
Dim LOOKUP_SHEET As String

'開始時間設定
sTIME = Time

MASTER_SHEET = COMPARATOR_FORM.ComboBox1
MASTER_ROW1 = COMPARATOR_FORM.TextBox1
MASTER_ROW2 = COMPARATOR_FORM.TextBox2
MASTER_ROW3 = COMPARATOR_FORM.TextBox3
LOOKUP_SHEET = COMPARATOR_FORM.ComboBox2
LOOKUP_ROW1 = COMPARATOR_FORM.TextBox4
LOOKUP_ROW2 = COMPARATOR_FORM.TextBox5
LOOKUP_ROW3 = COMPARATOR_FORM.TextBox6

Unload COMPARATOR_FORM

'②-1配列サイズ取得
'END入力行の検索
Dim LAST_COLUMN_MASTER As Long
Dim LAST_COLUMN_LOOKUP As Long
Dim LAST_ROW_LOOKUP As Long
Dim Obj_ENDCOLUMN_MASTER As Object
Dim Obj_ENDCOLUMN_LOOKUP As Object
Dim Obj_ENDROW_LOOKUP As Object

'②-2検索データシートに配列設定
'配列の設定
Dim MASTER_ITEM1 As Variant '検索項目列1の格納場所
Dim MASTER_ITEM2 As Variant '検索項目列2の格納場所
Dim MASTER_ITEM3 As Variant
Dim LOOKUP_ITEM1 As Variant '検索対象列1の格納場所
Dim LOOKUP_ITEM2 As Variant '検索対象列2の格納場所
Dim LOOKUP_ALL As Variant '検索対象のシート全データを配列に格納
Dim MAT As Variant '一致時のLOOKUP_ALL分離格納場所
Dim INP1 As Variant '不完全一致時の分離格納場所1
Dim INP2 As Variant '不完全一致時の分離格納場所2
Dim CONF As Variant '不一致時のLOOKUP_ALL分離格納場所
Dim Dic1 As Object
Dim Dic2 As Object
Dim i As Long 'LOOPカウント用
Dim j As Long 'LOOPカウント用
Dim k As Variant 'LOOKUP_ITEM1の個別要素LOOP用変数
Dim r As Variant 'LOOKUP_ITEM2の個別要素LOOP用変数
Dim MASTER_ROW1_NUM As Integer
Dim MASTER_ROW2_NUM As Integer
Dim MASTER_ROW3_NUM As Integer
Dim AD1 As String
Dim LOOKUP_ROW1_NUM As Integer
Dim LOOKUP_ROW2_NUM As Integer
Dim AD2 As String
Dim AD3 As String
Dim AD4 As String
Dim AD5 As String
Dim AD6 As String
Dim AD7 As String
Dim AD8 As String
Dim AD9 As String
Dim AD10 As String
Dim AD11 As String
Dim AD12 As String
Dim AD13 As String
Dim AD14 As String
Dim m As Integer
Dim n As Long
Dim o As Long
Dim p As Long
Dim q As Integer 'シート名重複回避用
Dim s As Long
Dim t As Long
Dim u As Long

'MASTERデータシートの最終行取得
Sheets(MASTER_SHEET).Select
Set Obj_ENDCOLUMN_MASTER = Cells.Find(what:="END", after:=Cells(65536, 1), Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchByte:=False)
If Obj_ENDCOLUMN_MASTER Is Nothing Then
MsgBox "MASTERデータのシートの指定列最終行の下にENDを入力してください"
GoTo N9999
Else: LAST_COLUMN_MASTER = Obj_ENDCOLUMN_MASTER.row - 1
End If

'MASTERの項目を格納
MASTER_ROW1_NUM = Cells(1, MASTER_ROW1).Column '27進数の10進数変換がめんどくさいので投げやり
MASTER_ROW2_NUM = Cells(1, MASTER_ROW2).Column
MASTER_ROW3_NUM = Cells(1, MASTER_ROW3).Column
AD1 = Cells(1, MASTER_ROW1_NUM).Address '同上
AD6 = Cells(LAST_COLUMN_MASTER, MASTER_ROW1_NUM + 1).Address
AD9 = Cells(1, MASTER_ROW2_NUM).Address
AD10 = Cells(LAST_COLUMN_MASTER, MASTER_ROW2_NUM + 1).Address
AD13 = Cells(1, MASTER_ROW3_NUM).Address
AD14 = Cells(LAST_COLUMN_MASTER, MASTER_ROW3_NUM).Address
MASTER_ITEM1 = Range(Range(AD1), Range(AD6)).Value
MASTER_ITEM2 = Range(Range(AD9), Range(AD10)).Value
MASTER_ITEM3 = Range(Range(AD13), Range(AD14)).Value

'検索データシートの最終行取得
Sheets(LOOKUP_SHEET).Select
Set Obj_ENDCOLUMN_LOOKUP = Cells.Find(what:="END", after:=Cells(65536, 1), Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchByte:=False)
If Obj_ENDCOLUMN_LOOKUP Is Nothing Then
MsgBox "比較対象シートの指定列最終行の下にENDを入力してください"
GoTo N9999
Else: LAST_COLUMN_LOOKUP = Obj_ENDCOLUMN_LOOKUP.row - 1
End If

'検索データシートの最終列取得
Set Obj_ENDROW_LOOKUP = Cells.Find(what:="END", after:=Cells(1, 256), Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchByte:=False)
If Obj_ENDROW_LOOKUP.Column = 1 Then
MsgBox "比較対象シートの1行目の最終列の横にENDを入力してください"
GoTo N9999
Else: LAST_ROW_LOOKUP = Obj_ENDROW_LOOKUP.Column - 1
End If

'検索対象項目を格納
LOOKUP_ROW1_NUM = Cells(1, LOOKUP_ROW1).Column '27進数の10進数変換がめんどくさいので投げやり
LOOKUP_ROW2_NUM = Cells(1, LOOKUP_ROW2).Column
AD2 = Cells(1, LOOKUP_ROW1_NUM).Address '同上
AD3 = Cells(LAST_COLUMN_LOOKUP, LOOKUP_ROW1_NUM).Address
AD7 = Cells(1, LOOKUP_ROW2_NUM).Address
AD8 = Cells(LAST_COLUMN_LOOKUP, LOOKUP_ROW2_NUM).Address
LOOKUP_ITEM1 = Range(Range(AD2), Range(AD3)).Value
LOOKUP_ITEM2 = Range(Range(AD7), Range(AD8)).Value

'検索対象のデータを配列データに全格納
AD4 = Cells(LAST_COLUMN_LOOKUP, LAST_ROW_LOOKUP).Address
LOOKUP_ALL = Range(Range("A1"), Range(AD4)).Value

ReDim MAT(1 To LAST_COLUMN_LOOKUP, 1 To LAST_ROW_LOOKUP + 1)
ReDim INP1(1 To LAST_COLUMN_LOOKUP, 1 To LAST_ROW_LOOKUP + 1)
ReDim INP2(1 To LAST_COLUMN_LOOKUP, 1 To LAST_ROW_LOOKUP + 1)
ReDim CONF(1 To LAST_COLUMN_LOOKUP, 1 To LAST_ROW_LOOKUP)

'DICTIONARY比較
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")

For i = 1 To LAST_COLUMN_MASTER
If Not Dic1.exists(MASTER_ITEM1(i, 1)) Then Dic1.Add MASTER_ITEM1(i, 1), MASTER_ITEM3(i, 1)
If Not Dic2.exists(MASTER_ITEM2(i, 1)) Then Dic2.Add MASTER_ITEM2(i, 1), MASTER_ITEM3(i, 1)
Next i

For Each k In LOOKUP_ITEM1
j = j + 1 'LOOPカウンタ

If k = "END" Then
GoTo N8888
End If

If j <> 1 Then
GoTo N100
Else
End If

For Each r In LOOKUP_ITEM2

N100: If j = u Then
GoTo N1111
Else
End If

If Dic1.exists(k) Then
If Dic2.exists(r) Then
o = o + 1 'MAT行追加LOOP
m = 1
For m = 1 To LAST_ROW_LOOKUP
MAT(o, m) = LOOKUP_ALL(j, m)
Next m
MAT(o, m) = Dic1.Item(k)
Else
s = s + 1
m = 1
For m = 1 To LAST_ROW_LOOKUP
INP1(s, m) = LOOKUP_ALL(j, m) 'MASTERの検索要素1にあって検索要素2はないものはINPERFECT1へ
Next m
INP1(s, m) = Dic1.Item(k)
End If
Else
If Dic2.exists(r) Then
t = t + 1
m = 1
For m = 1 To LAST_ROW_LOOKUP
INP2(t, m) = LOOKUP_ALL(j, m) 'MASTERの検索要素1になくて検索要素2はあるものはINPERFECT1へ
Next m
INP2(t, m) = Dic2.Item(r)
Else
p = p + 1 'CONF行追加LOOPカウンタ
m = 1
For m = 1 To LAST_ROW_LOOKUP
CONF(p, m) = LOOKUP_ALL(j, m) 'CONF列追加LOOP
Next m
End If
End If
u = u + 1
Next r
N1111: Next k

N8888:
Set Dic1 = Nothing
Set Dic2 = Nothing
Set LOOKUP_ITEM1 = Nothing
Set LOOKUP_ITEM2 = Nothing
Set LOOKUP_ALL = Nothing

'シート名取得ルーチン
Sheets.Add
q = 1
On Error Resume Next
Do
Err.Clear
ActiveSheet.Name = "RESULT" & "(" & CStr(q) & ")"
q = q + 1
Loop Until Err.Number = 0
'必要ならここに"On Error Goto ○○○○"を追記する
Cells(1, 1) = "MATCH"
Cells(2 + o, 1) = "INPERFECT1"
Cells(3 + o + s, 1) = "INPERFECT2"
Cells(4 + o + s + t, 1) = "CONFLICT"

If o = 0 Then
GoTo N9200
Else: Range("A2").Resize(o, LAST_ROW_LOOKUP + 1).Value = MAT
End If

N9200:
If s = 0 Then
GoTo N9400
Else:
AD11 = Cells(3 + o, 1).Address
Range(AD11).Resize(s, LAST_ROW_LOOKUP + 1).Value = INP1
End If

N9400:
If t = 0 Then
GoTo N9600
Else:
AD12 = Cells(4 + o + s, 1).Address
Range(AD12).Resize(t, LAST_ROW_LOOKUP + 1).Value = INP2
End If

N9600:
If p = 0 Then
GoTo N9998
Else:
AD5 = Cells(5 + o + s + t, 1).Address
Range(AD5).Resize(p, LAST_ROW_LOOKUP).Value = CONF
End If


'処理時間算出ルーチン
N9998:
eTIME = Time
TOTAL_TIME = (eTIME - sTIME) * 24 * 60 * 60
MsgBox TOTAL_TIME & "sec"

N9999:
Application.ScreenUpdating = True
End Sub