'''''''''''''''''''''
Private Function Select_Operator(ByVal formula As String, ByVal names As Variant) As Variant
'' 比較演算子の判定 names 配列型の名前リスト
'' ==: 完全一致
'' = : 部分一致
'' !=: 否定
'' > : 大なり
'' >=: 以上
'' < : 小なり
'' <=: 以下
'''''''''''''''''''''
Dim operator, str_item As String
Dim sep_str As Variant
Dim i, num As Long
Dim search_text As String
Dim name_is_left_hand As Boolean
On Error Resume Next
name_is_left_hand = True
num = 999
If InStr(formula, "=") > 0 Then
For Each operator In Array("==", "!=", ">=", "=>", "<=", "=<", "=")
If InStr(formula, operator) > 0 Then Exit For
Next
ElseIf InStr(formula, ">") > 0 Then
operator = ">"
ElseIf InStr(formula, "<") > 0 Then
operator = "<"
Else
operator = "NA"
End If
'' 検索文字を分割
If operator <> "NA" Then
sep_str = Split(Replace(Replace(formula, " ", ""), _
" ", ""), operator)
'' 列番号を検索
i = 0
Do
num = WorksheetFunction.Match(sep_str(i), names, 0) - 1
'' ヒットしなければ右辺を検索
If num = 999 Then
name_is_left_hand = False
If i = 0 Then
i = i + 1
ElseIf i = 1 Then
Exit Do
End If
Else
Exit Do
End If
Loop
'' 右辺でヒットした場合は、比較演算子を逆転
If name_is_left_hand = False Then
Select Case operator
Case "<"
operator = ">"
Case "<=", "=<"
operator = ">="
Case ">=", "=>"
operator = "<="
End Select
search_text = sep_str(0)
ElseIf name_is_left_hand = True Then
search_text = sep_str(1)
End If
If num = 999 Then
'' 列名が見つからなかった場合はエラー表示
operator = "Error"
search_text = "Error"
End If
Else
search_text = formula
num = 999
End If
Select_Operator = Array(operator, num, search_text)
End Function
Private Function Separate_Formula(ByVal formula As String) As Variant
'' フィルター処理で使う評価式の判定
'' and検索: &&
'' or 検索: ||
Dim andLen, orLen, cutStr As Long
Dim pat, texts As Collection
Dim formula_text As String
Set pat = New Collection
Set texts = New Collection
'' 空白文字の削除
formula_text = Replace(formula, " ", "")
formula_text = Replace(formula_text, " ", "")
'' &&または||で文字が分割できなくなるまで継続
Do
'' 条件判定
andLen = InStr(formula_text, "&&")
orLen = InStr(formula_text, "||")
'' 条件を振り分け
If andLen = 0 And orLen = 0 Then
pat.Add "end"
texts.Add formula_text
Exit Do
ElseIf andLen > 0 And orLen = 0 Then
pat.Add "and"
cutStr = andLen
ElseIf andLen = 0 And orLen > 0 Then
pat.Add "or"
cutStr = orLen
ElseIf andLen > 0 And orLen > 0 Then
If andLen < orLen Then
pat.Add "and"
cutStr = andLen
ElseIf andLen > orLen Then
pat.Add "or"
cutStr = orLen
End If
End If
'' 文字を分割して登録
texts.Add left(formula_text, cutStr - 1)
formula_text = mid(formula_text, cutStr + 2)
Loop
Separate_Formula = Array(pat, texts)
End Function
Private Function Sort_Data_Table(ByVal dic As Object, ByVal col_name As String, _
ByVal order As Long) As Object
'' dic: dictionary型オブジェクト
'' col_name: ソートをかける基準の列名
'' order: 0; 昇順 1; 降順
Dim col_num As Long
Dim col_type As String
Dim ar() As Variant
Dim dic_list, dic_all_list, new_dic As Object
Dim ltext As Variant
Dim qs As Variant
Dim i As Long
Dim ikey As Variant
Dim wlist As Variant
Dim keylist As Variant
Dim anum As Long
'' 列番号の検索
col_num = WorksheetFunction.Match(col_name, dic.item("name"), 0) - 1
'' データ型の検索
col_type = dic.item("type")(col_num)
'' 対象列データの取得
Set dic_list = Set_Dictionary
Set dic_all_list = Set_Dictionary
For Each ikey In dic
'If ikey <> "primary_key" Or ikey <> "name" Or ikey <> "type" Then
Select Case ikey
Case "primary_key", "name", "type"
Case Else
If dic_list.exists(dic.item(ikey)(col_num)) = False Then
dic_list.Add dic.item(ikey)(col_num), Text_Format(dic.item(ikey)(col_num), col_type)
End If
dic_all_list.Add ikey, Text_Format(dic.item(ikey)(col_num), col_type)
End Select
'End If
Next
ltext = dic_all_list.items
'' 並び替えの必要がなければ処理を終了
If dic_list.Count < 2 Then
Debug.Print "並び替えを必要とするデータが存在しませんでした。"
Set Sort_Data_Table = dic
Exit Function
End If
'' quicksortで並び替え
qs = dic_list.items
qs = QuickSort(qs, LBound(qs), UBound(qs), order)
'' 元のリストを並び変える行番号を検索
wlist = Which_List(ltext, qs)
'' 出力用のdictionary作成
Set new_dic = Set_Dictionary
'' ヘッダー部分を登録
For Each ikey In dic
If ikey = "primary_key" Or ikey = "type" Or ikey = "name" Then
new_dic.Add ikey, dic.item(ikey)
End If
Next
keylist = dic.keys
For i = LBound(keylist) To UBound(keylist)
If keylist(i) = "name" Then
anum = i + 1
Exit For
End If
Next
For Each ikey In wlist
new_dic.Add keylist(ikey + anum), dic.item(keylist(ikey + anum))
Next
Set Sort_Data_Table = new_dic
End Function
Private Function Which_List(ByVal target As Variant, ByVal data As Variant) As Variant
'' targetで指定したリストの位置を番号で反す
'' target, dataともに1次元配列 targetが文字列の場合は配列に変換して検索する
Dim num, i As Long
Dim dic As Object
Dim ikey As Variant
Dim dkey As Variant
If Search_Dimentions(target) = 0 Then
target = Array(target)
End If
Set dic = Set_Dictionary
For Each ikey In data
num = LBound(target)
For Each dkey In target
If ikey = dkey Then
dic.Add CStr(num), num
End If
num = num + 1
Next
Next
Which_List = dic.items
End Function
Private Function Format_List() As Variant
Format_List = Array("日付", "時間", "数値", "文字列")
End Function
Private Function Text_Format(ByVal text As String, ByVal text_type As String) As Variant
Dim output As Variant
Select Case text_type
Case "日付", "時間"
output = CDate(text)
Case "数値"
output = CDbl(text)
Case Else
output = CStr(text)
End Select
Text_Format = output
End Function
Private Function Input_Format(ByVal text As String, ByVal text_type As String) As String
On Error Resume Next
Dim output As Variant
Select Case text_type
Case "日付"
output = Format(text, "yyyy-MM-dd")
Case "時間"
output = Format(text, "HH:mm:SS")
Case "数値"
output = CDbl(text)
Case Else
output = CStr(text)
End Select
Input_Format = output
End Function
Private Function Get_Table_List() As Variant
'' 既に作成されているテーブル名のリストを反す
Dim buf As String
Dim dtlist As Variant
buf = dir(working_dir & "\*.txt")
dtlist = ""
Do While buf <> ""
dtlist = dtlist & WorksheetFunction.Substitute(buf, ".txt", "", 1) & vbTab
buf = dir()
Loop
If right(dtlist, 1) = vbTab Then
dtlist = left(dtlist, Len(dtlist) - 1)
End If
Get_Table_List = Split(dtlist, vbTab)
End Function
Public Function select4dic(ByVal data_object As Object, ByVal select_column_names As Variant) As Object
Set select4dic = Select_Columns(data_object, select_column_names)
End Function
Private Function Select_Columns(ByVal dic As Object, ByVal col_name As Variant) As Object
'' namesに指定したデータの項目名(列名)だけを選択して出力する
'' namesは1次元Array
'' primary keyの列名はcol_nameに必ず入れること
Dim dt, New_dt() As Variant
Dim new_dic As Object
Dim ch_dic As Object
Dim i, j As Long
Dim ar() As Variant
Dim pk As Long
Dim pk_name As String
Dim check_names As String
Dim ckey As Variant
'' 列名の確認
check_names = join(col_name, vbTab)
If Not InStr(check_names, "NAME") > 0 Then
col_name = Split("NAME" & vbTab & check_names, vbTab)
End If
'' primary key の確認
pk = CLng(dic.item("primary_key")(1))
pk_name = dic.item("name")(pk)
pk = WorksheetFunction.Match(pk_name, col_name, 0) - 1
'' 配列に変換
dt = Dictionary_to_Array(dic)
'' 配列を列名で列単位にまとめる
Set new_dic = Set_Dictionary
For j = LBound(dt, 2) To UBound(dt, 2)
ReDim ar(LBound(dt, 1) To UBound(dt, 1))
For i = LBound(dt, 1) To UBound(dt, 1)
ar(i) = dt(i, j)
Next
'' dictionaryに登録
new_dic.Add ar(2), ar
Next
'' 列をピックアップ
Set ch_dic = Set_Dictionary
For Each ckey In col_name
If new_dic.exists(ckey) Then
ch_dic.Add ckey, new_dic.item(ckey)
End If
Next
'' dictionaryを配列に戻す
ReDim New_dt(LBound(dt, 1) To UBound(dt, 1), 0 To ch_dic.Count - 1)
j = 0
For Each ckey In ch_dic
ar = ch_dic.item(ckey)
For i = LBound(ar) To UBound(ar)
New_dt(i, j) = ar(i)
Next
j = j + 1
Next
''配列をdictionaryに変換して元のデータを上書き
Set new_dic = Array_to_Dictionary(New_dt, pk)
Set Select_Columns = OverWrite_DataTable(dic, new_dic)
End Function
Private Function Shrink_Array(ByVal dt As Variant, ByVal remove_num As Long) As Variant
'' 1次元配列から指定した番号の列を削除
Dim ar() As Variant
Dim num As Long
Dim i As Long
If Search_Dimentions(dt) <> 1 Then
Debug.Print "入力データが1次元配列ではありません。"
Exit Function
End If
ReDim ar(LBound(dt) To UBound(dt) - 1)
For i = LBound(dt) To UBound(dt)
If i < remove_num Then
ar(i) = dt(i)
ElseIf i > remove_num Then
ar(i - 1) = dt(i)
End If
Next
Shrink_Array = ar
End Function
Public Function cbind(ByVal dic As Object, ByVal join_key As String, ByVal join_dic As Object) As Object
'' データを横に結合
Set cbind = Left_Join(dic, join_key, join_dic)
End Function
Public Function rbind(ByVal dic As Object, ByVal union_dic As Object) As Object
'' データを縦に結合
Set rbind = Under_Union(dic, union_dic)
End Function
Private Function Under_Union(ByVal dic As Object, ByVal add_dic As Object) As Object
'' データを縦に結合
'' 既存のデータテーブルに新たな行を追加
'' add_data: Dictionary型を内包する配列型(array)
Dim new_dic As Object
Dim cName As Variant
Dim ncol As Long
Dim pk As Long
Dim ndim As Long
Dim nrow As Long
Dim dt, New_dt As Variant
Dim add_name As Object
Dim i As Long
Dim key_name As Variant
Dim d As Variant
Dim ikey As Variant
Dim dkey As Variant
Dim d_name As Variant
Dim d_d As Variant
'' 列名取得
cName = dic.item("name")
'' プライマリーキー列番号
pk = dic.item("primary_key")(1)
'' 列名をもとにDictionaryを作成
Set new_dic = Set_Dictionary
For Each key_name In cName
new_dic.Add key_name, ""
Next
'' 結合するデータから列名取得
Set add_name = Set_Dictionary
'' 列名を取得
d_name = add_dic.item("name")
For Each key_name In d_name
add_name.Add key_name, ""
Next
'' 新規データを登録
For Each d In add_dic
'' ヘッダー部分と登録済みのキーは除外
If d = "primary_key" Or d = "name" Or d = "type" Or dic.exists(d) Then GoTo Continue
'' データを配列に取り込む
d_d = add_dic.item(d)
For i = LBound(d_d) To UBound(d_d)
add_name.item(d_name(i)) = d_d(i)
Next
''登録用dictionaryを修正
For Each ikey In add_name
If new_dic.exists(ikey) Then
new_dic.item(ikey) = add_name.item(ikey)
End If
Next
'' データ行を追加, 既存の場合は上書き
dic.Add d, new_dic.items
'' 既存のデータを一度消去
For Each dkey In new_dic
new_dic.item(dkey) = ""
Next
For Each dkey In add_name
add_name.item(dkey) = ""
Next
d_d = ""
Continue:
Next
''データを保存
Set Under_Union = dic
End Function
Private Function Left_Join(ByVal dic As Object, ByVal key_name As String, _
ByVal add_dic As Object) As Object
'' dicのkey_name列をキーとしてadd_dicの情報を右に結合する
Dim num, anum As Long
Dim add_table As Variant
Dim New_table() As Variant
Dim new_dic As Object
Dim ar() As Variant
Dim bname, aname As Variant
Dim i, j As Long
Dim dummy As String
Dim ikey As Variant
Dim d As Variant
Dim skey As Variant
bname = dic.item("name")
'' 指定する列番号の検索
num = WorksheetFunction.Match(key_name, bname, 0) - 1
'' 追加するデータも同様に列を検索し、該当列は削除
aname = add_dic.item("name")
anum = WorksheetFunction.Match(key_name, aname, 0) - 1
'' 配列に変換
add_table = Dictionary_to_Array(add_dic)
''dictionary型に変換
Set new_dic = Set_Dictionary
ReDim ar(LBound(add_table, 2) To UBound(add_table, 2) - 1)
'ReDim New_table(LBound(add_table, 1) To UBound(add_table, 1), LBound(add_table, 2) To UBound(add_table, 2) - 1)
For i = LBound(add_table, 1) To UBound(add_table, 1)
For j = LBound(add_table, 2) To UBound(add_table, 2)
If j < anum Then
ar(j) = add_table(i, j)
ElseIf j > anum Then
ar(j - 1) = add_table(i, j)
End If
Next
'' データを登録
Select Case ar(0)
Case "TYPE"
new_dic.Add "type", Shrink_Array(ar, 0)
Case "NAME"
new_dic.Add "name", Shrink_Array(ar, 0)
Case Else
new_dic.Add add_table(i, anum), Shrink_Array(ar, 0)
End Select
'' 格納したデータを消去
For j = LBound(ar) To UBound(ar)
ar(j) = ""
Next
Next
dummy = String(UBound(aname) - 1, vbTab)
'' キーをもとに結合
For Each ikey In dic
Select Case ikey
Case "primary_key"
GoTo Continue
Case "type", "name"
d = dic.item(ikey)
skey = d(num)
dic.item(ikey) = Split(join(d, vbTab) & vbTab & join(new_dic.item(ikey), vbTab), vbTab)
Case Else
d = dic.item(ikey)
skey = d(num)
If new_dic.exists(skey) Then
dic.item(ikey) = Split(join(d, vbTab) & vbTab & join(new_dic.item(skey), vbTab), vbTab)
Else
dic.item(ikey) = Split(join(d, vbTab) & vbTab & dummy, vbTab)
End If
End Select
Continue:
Next
Set Left_Join = dic
''Left_Join = Dictionary_to_Array(dic)
End Function
''''''''''''''''''''''''''''''''
Private Function Insert_New_Column_To_DataTable(ByVal DataTable_name As String, ByVal num As Long, _
ByVal col_type As Variant, ByVal col_name As Variant) As Object
'' データテーブルに列を追加
'' DataTable_name: DT名
'' numで指定した列番号のあとに新規列を追加
'' col_type: 追加する列のデータ型
'' col_name: 追加する列名
'' col_typeとcol_nameはデータ数が同じである必要があります。
''''''''''''''''''''''''''''''''