エクセルVBAで作る 小規模用情報共有DBシステム ファイルアップロードも可能 テスト投稿 

●演習シート用
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.CountLarge <= 100 Then

        If Target.Count > 1 Then Exit Sub
        
        Dim t_address
        Dim t_value
        
        t_address = Target.Address(False, False)
        t_value = Target.Value
        
        'Target.Addressを条件にテーブルからwordを取り出す
        'wordとTarget.Valueを比較し、合っていたら文字の色を青にする、以外は赤にする
        'xxと入れたら答えを記入
        
        If t_value = "" Then Exit Sub
        
        
        Dim dic_obj_select_info As Object
        Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
        
        Dim select_dto As Object
            
        dic_obj_select_info.Add GB_PLACE, t_address
    
        Set select_dto = select_info(GB_T_FILL_WORD_TABLE, dic_obj_select_info, fill_word_table_map)
        
'        Debug.Print "DB" & select_dto.Item(GB_WORD)
'        Debug.Print "セル" & select_dto.Item(GB_WORD)

        If select_dto.Count > 0 Then
    
            If t_value = select_dto.Item(1).Item(GB_WORD) Then
            
                Range(t_address).Font.ColorIndex = 5
                Range(t_address).Font.Bold = True
            
            'xxと入力された場合は答えを出す。
            ElseIf t_value = "xx" Or t_value = "xx" Then
            
                Range(t_address).Value = select_dto.Item(1).Item(GB_WORD)
            
                Range(t_address).Font.ColorIndex = 1
                Range(t_address).Font.Bold = True
                
                
            Else
                
                Range(t_address).Font.ColorIndex = 3
                Range(t_address).Font.Bold = True
                
                
            End If
    
        End If
    
    End If
    

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

●edit_form用
Private Sub Label6_Click()

End Sub

Private Sub rate_ComboBox_Change()

End Sub

Private Sub regist_CommandButton_Click()
    
    Call rgist_fill_question(2)
    
End Sub

Private Sub get_col_CommandButton_Click()

    edit_Form.col_TextBox = ActiveCell.Column

End Sub

Private Sub get_row_CommandButton_Click()
        
    edit_Form.row_TextBox.Value = ActiveCell.row

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub summary_TextBox_Change()

End Sub

Private Sub text_CommandButton_Click()

    '---------------------temporary_tableからidを取得
    Dim id As Long
    Dim setter As Object
    Dim getter As Object
    
    Set setter = CreateObject("Scripting.Dictionary")
    Set getter = CreateObject("Scripting.Dictionary")
    
    setter.Add GB_T_ID, 1
    
    Set getter = select_info(GB_T_TEMPORARY_TABLE, setter, temporary_table_map)
    
    id = getter.Item(1).Item(GB_ID)
    
    Set setter = Nothing
    Set getter = Nothing
    
    
    '---------------------law_info_tableのテキストページをフォームの値で更新する
    Dim text_page As Long
    Dim setter_target As Object
    Dim setter_value As Object
    
    Set setter_target = CreateObject("Scripting.Dictionary")
    Set setter_value = CreateObject("Scripting.Dictionary")
    text_page = Me.text_TextBox
    
    setter_target.Add GB_ID, id
    setter_value.Add GB_TEXT, text_page
    
    Call update_info(GB_T_LAW_INFO_TABLE, setter_target, setter_value, law_info_table_map)
    
    '---------------------temporary_tableのテキストページも更新
    Set setter_target = Nothing
    Set setter_target = CreateObject("Scripting.Dictionary")
    setter_target.Add GB_T_ID, 1
    Call update_info(GB_T_TEMPORARY_TABLE, setter_target, setter_value, temporary_table_map)
    
    
    Set setter_target = Nothing
    Set setter_value = Nothing
    
    MsgBox "登録しました"

End Sub

Private Sub text_TextBox_Change()

End Sub

Private Sub UserForm_Initialize()
'
'    重要度の値をテンポラリーテーブルから取得
'    Dim dic_obj_select_info As Object
'    Dim select_dto As Object
'    Dim t_rate As Object
'
'    検索条件の入れ物を用意
'    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'
'    dic_obj_select_info.Add GB_ID, 1
'
'    select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
'
'    t_rate = select_dto.Item(1).Item(GB_RATE)
'
    With rate_ComboBox

        .AddItem 1
        .AddItem 2
        .AddItem 3

    End With


'    If t_rate <> "" Then
'
'        rate_ComboBox.ListIndex = t_rate
'
'    Else
'
'        rate_ComboBox.ListIndex = -1
'
'
'    End If
'
End Sub

★edit_form用各ボタン名
licence_TextBox
category_TextBox
no_TextBox
get_row_CommandButton
row_TextBox
get_col_CommandButton
col_TextBox
rate_ComboBox
text_TextBox
text_CommandButton
regist_CommandButton

●fill_chara_Form用
Private Sub CommandButton1_Click()

End Sub

Private Sub create_fill_chara_Click()
    
    Call create_fill_in_the_blank_character
    
End Sub

Private Sub regist_fill_chara_Click()

    Dim last_row As Long
    Dim last_col As Long
    
    
    last_row = fill_chara_Form.last_row_text
    last_col = fill_chara_Form.last_col_text
    
    
    Call register_fill_in_the_blank_character(last_row, last_col)


End Sub
Private Sub delete_line_Button_Click()

    Call delete_line

End Sub

Private Sub drow_line_Button_Click()

    Call drow_line

End Sub

Private Sub drow_line_Button2_Click()
    
    Call drow_line2
    
End Sub

Private Sub row_delete_Click()
    
    Call row_delete_1
    
End Sub

Private Sub row_insert_Click()
    
    Call row_insert_1

End Sub

★fill_chara_Form用各ボタン
row_insert
row_delete
drow_line_Button
drow_line_Button2
delete_line_Button


●index_Form
Private Sub CommandButton1_Click()
    
    regist_Form.Show vbModeless
    
End Sub

Private Sub open_law_Form_Click()
    
    law_Form.Show vbModeless

End Sub

Private Sub opne_fill_chara_form_Click()

    fill_chara_Form.Show vbModeless

End Sub

Private Sub UserForm_Click()

End Sub

★index_Form用各ボタン
open_law_Form
opne_fill_chara_form
CommandButton1

●law_Form
'Private Sub CommandButton1_Click()
'
'
'    Dim str As String
'
'    str = UserForm1.TextBox1.Value
'
'    '改行コードを削除
'
'    str = Replace(str, vbCrLf, "")
''    Debug.Print str
'
'
''    Call get_kanji(str)
'    Call decompose_string(str)
'
'End Sub

Private Sub CommandButton2_Click()
    Call create_fill_in_the_blank_character
End Sub

Private Sub CommandButton3_Click()

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub TextBox3_Change()

End Sub
Private Sub law_CommandButton_Click()

    Dim str As String
    str = law_Form.law_TextBox.Value
    
'    '改行コードを削除
'    str = Replace(str, vbCrLf, "")
'
'    Call decompose_string(str)
'

    str = Replace(str, vbCrLf, "/")
    
    Call decompose_string_direct(str)
    

End Sub

Private Sub law_TextBox_Change()

End Sub

Private Sub reset_Button_Click()
    
    Call reset_question

End Sub

★law_Form用ボタン
reset_Button
law_CommandButton


●regist_Form
Private Sub category_ComboBox_Change()

End Sub

Private Sub get_col_CommandButton_Click()

    regist_Form.col_TextBox = ActiveCell.Column

End Sub

Private Sub get_row_CommandButton_Click()
        
    regist_Form.row_TextBox.Value = ActiveCell.row

End Sub

Private Sub Label9_Click()

End Sub
Private Sub rate_ComboBox_Change()

    



End Sub

Private Sub summary_TextBox_Change()

End Sub

Private Sub UserForm_Initialize()
    
    With licence_ComboBox
        .AddItem "消防4類乙"
    End With
    
    licence_ComboBox.ListIndex = 0

    With category_ComboBox
        .AddItem "暗記"

        
    End With

    category_ComboBox.ListIndex = 0
    
    With rate_ComboBox
        
        .AddItem 1
        .AddItem 2
        .AddItem 3
    
    End With
    
    rate_ComboBox.ListIndex = 0
    
End Sub
Private Sub CommandButton1_Click()

End Sub
Private Sub regist_CommandButton_Click()

    If regist_Form.no_TextBox = "" Then
    
        MsgBox "NOが指定されていません"
        End
    
    End If



    Call rgist_fill_question(1)


End Sub

Private Sub UserForm_Click()

End Sub

★regist_Form用ボタン
licence_ComboBox
category_ComboBox
no_TextBox
get_row_CommandButton
row_TextBox
get_col_CommandButton
col_TextBox
rate_ComboBox
regist_CommandButton

●DB用
Option Explicit
Enum law_info_table
    id = 1
    licence
    category
    num
    row
    col
    t_rate
    t_summary
    del_flg
    t_text
    t_text_name
    times
    sub_category

End Enum

Enum fill_word_table

    id = 1
    place
    word

End Enum

Enum temporary_table

    t_id = 1
    id
    licence
    category
    num
    row
    col
    t_rate
    t_summary
    t_text

End Enum

Enum number_table

    t_id = 1
    number1
    number2
    number3
    
End Enum

Enum question_cycle_table

    t_id = 1
    license
    sub_category
    times

End Enum
Function select_info(table_name As String, ByVal select_dto As Object, table_map As Object) As Object
    '情報の曖昧検索をする関数
    '引数1:検索するテーブル名
    '引数2:検索条件
    '引数3:検索対象テーブルのマッピング情報
        
    Dim tbList As ListObject
    Dim record_count As Long
    Dim i As Long
    Dim j As Long
    Dim dicKey_select As Variant
    Dim serch_count As Long
    Dim record As String
    Dim search_Word As String
    
    serch_count = 0
'    Dim dicItem_select As Variant
    
    Dim dicKey_table As Variant
    
    dicKey_select = select_dto.keys
'    dicItem_select = select_dto.items
    
    dicKey_table = table_map.keys
        
    '検索結果返却用
    Dim dic_obj_result As Object
    Set dic_obj_result = CreateDictionary

'    Worksheets(table_name).Activate
    
    Set tbList = CreateTableList(table_name)
    'Set tbList = Worksheets(table_name).ListObjects(table_name)

    record_count = tbList.ListRows.Count
    
    With ThisWorkbook.Worksheets(table_name)
    
        For i = 2 To record_count + 1
            
            For j = 0 To UBound(dicKey_select)
            
                'テーブルの検索対象情報
                
                'todo 検索語に関しては前段階で小文字に変換できないか考える
                'dictoinaryのキーの配列はすでに持ってるのだから、開けて変換して戻すくらいはできるはず
                
                search_Word = ""
                record = ""
                
                search_Word = select_dto.Item(dicKey_select(j))
                search_Word = StrConv(LCase(search_Word), vbNarrow)
                'search_Word = Replace(search_Word, " ", "*")
                
                record = .Cells(i, table_map.Item(dicKey_select(j))).Value
                record = StrConv(LCase(record), vbNarrow)
        
'                If Not record Like "*" & search_Word & "*" Then
'
'                    GoTo Skip
'
'                End If
                
                
                If Not record Like search_Word Then
                
                    GoTo Skip
        
                End If
                
                
                
            
'                If .Cells(i, table_map.Item(dicKey_select(j))).Value <> select_dto.Item(dicKey_select(j)) Then
'
'                    GoTo Skip
'
'                End If
            
            Next j
            
            '子ディクショナリ
            Dim c_dic_obj_result As Object
            Set c_dic_obj_result = CreateDictionary
            
            serch_count = serch_count + 1
            
            'ここに来れたなら、条件がすべて一致しているはず。
            For j = 0 To UBound(dicKey_table)
            
                'テーブルの目的の行を追加する
                c_dic_obj_result.Add dicKey_table(j), .Cells(i, table_map.Item(dicKey_table(j))).Value
            
            Next j
            
            '親ディクショナリに子ディクショナリを追加
            dic_obj_result.Add serch_count, c_dic_obj_result
            
            'for文を抜ける
'            Exit For
Skip:
                
        Next i
    
    End With
    
    Set select_info = dic_obj_result
    
End Function
Function insert_info(table_name As String, ByVal insert_dto As Object, table_map As Object)
'情報の登録を行う関数
    '引数1:登録を行テーブル名
    '引数2:登録内容
    '引数3:登録テーブルのマッピング情報
    
    Dim dicKey_table As Variant
    Dim dicKey_insert As Variant
    Dim i As Long
    
    Dim tbList As ListObject
    Set tbList = Worksheets(table_name).ListObjects(table_name)
    
    dicKey_insert = insert_dto.keys
    dicKey_table = table_map.keys

    With tbList.ListRows.Add
    
        For i = 0 To UBound(dicKey_insert)
            
            .Range(table_map.Item(dicKey_insert(i))).Value = insert_dto(dicKey_insert(i))
    
        Next i
    
    End With

End Function
Function update_info(table_name As String, ByVal search_dto, ByVal update_dto As Object, table_map As Object)
'情報を更新する関数 検索条件は複数可能
    '引数1:更新を行テーブル名
    '引数2:更新を行うレコードの条件(ID=1)とか
    '引数2:更新内容
    '引数3:更新テーブルのマップ
    
    Dim record_count As Long
    Dim dicKey_serch As Variant
    Dim dicKey_update As Variant
    Dim dicKey_table As Variant
    
    Dim tbList As ListObject
    Set tbList = Worksheets(table_name).ListObjects(table_name)

    Dim i As Long
    Dim j As Long
    
    record_count = tbList.ListRows.Count
    
    dicKey_serch = search_dto.keys
    dicKey_update = update_dto.keys
    dicKey_table = table_map.keys
    
    With Worksheets(table_name)
    
        For i = 2 To record_count + 1
            
            For j = 0 To UBound(dicKey_serch)
        
                If .Cells(i, table_map.Item(dicKey_serch(j))).Value <> search_dto.Item(dicKey_serch(j)) Then
                
                    GoTo Skip
                    
                End If
            
            Next j
            
            'ここに来れたなら、条件がすべて一致しているはず。
            For j = 0 To UBound(dicKey_update)
                
                .Cells(i, table_map.Item(dicKey_update(j))).Value = update_dto.Item(dicKey_update(j))
    
            Next j
        
Skip:
                
        Next i
        
    End With

End Function
Function law_info_table_map() As Object

    'テーブル内でのカラムの位置をマッピングするやーつ
    'このカラム名称だと1列目とか~
    
    Dim dic_obj_law_info_table As Object
    Set dic_obj_law_info_table = CreateObject("Scripting.Dictionary")

    dic_obj_law_info_table.Add GB_ID, law_info_table.id
    dic_obj_law_info_table.Add GB_LICENCE, law_info_table.licence
    dic_obj_law_info_table.Add GB_CATEGORY, law_info_table.category
    dic_obj_law_info_table.Add GB_NUM, law_info_table.num
    dic_obj_law_info_table.Add GB_ROW, law_info_table.row
    dic_obj_law_info_table.Add GB_COL, law_info_table.col
    dic_obj_law_info_table.Add GB_RATE, law_info_table.t_rate
    dic_obj_law_info_table.Add GB_SUMMARY, law_info_table.t_summary
    dic_obj_law_info_table.Add GB_DEL_FLG, law_info_table.del_flg
    dic_obj_law_info_table.Add GB_TEXT, law_info_table.t_text
    dic_obj_law_info_table.Add GB_C_TEXT_NAME, law_info_table.t_text_name
    dic_obj_law_info_table.Add GB_C_TIMES, law_info_table.times
    dic_obj_law_info_table.Add GB_C_SUB_CATEGORY, law_info_table.sub_category
    
    Set law_info_table_map = dic_obj_law_info_table

End Function
Function fill_word_table_map() As Object

    Dim dic_obj_fill_word_table As Object
    Set dic_obj_fill_word_table = CreateObject("Scripting.Dictionary")

    dic_obj_fill_word_table.Add GB_ID, fill_word_table.id
    dic_obj_fill_word_table.Add GB_PLACE, fill_word_table.place
    dic_obj_fill_word_table.Add GB_WORD, fill_word_table.word

    Set fill_word_table_map = dic_obj_fill_word_table

End Function
Function temporary_table_map() As Object
    
    Dim dic_obj_temporary_table As Object
    Set dic_obj_temporary_table = CreateObject("Scripting.Dictionary")

    dic_obj_temporary_table.Add GB_T_ID, temporary_table.t_id
    dic_obj_temporary_table.Add GB_ID, temporary_table.id
    dic_obj_temporary_table.Add GB_LICENCE, temporary_table.licence
    dic_obj_temporary_table.Add GB_CATEGORY, temporary_table.category
    dic_obj_temporary_table.Add GB_NUM, temporary_table.num
    dic_obj_temporary_table.Add GB_ROW, temporary_table.row
    dic_obj_temporary_table.Add GB_COL, temporary_table.col
    dic_obj_temporary_table.Add GB_RATE, temporary_table.t_rate
    dic_obj_temporary_table.Add GB_SUMMARY, temporary_table.t_summary
    dic_obj_temporary_table.Add GB_TEXT, temporary_table.t_text
    
    Set temporary_table_map = dic_obj_temporary_table

End Function
Function number_table_map() As Object
    
    Dim dic_obj_temporary_table As Object
    Set dic_obj_temporary_table = CreateObject("Scripting.Dictionary")

    dic_obj_temporary_table.Add GB_T_ID, number_table.t_id
    dic_obj_temporary_table.Add GB_NUMBER1, number_table.number1
    dic_obj_temporary_table.Add GB_NUMBER2, number_table.number2
    dic_obj_temporary_table.Add GB_NUMBER3, number_table.number3

    Set number_table_map = dic_obj_temporary_table

End Function
Function question_cycle_table_map() As Object

    Dim dic_obj As Object
    Set dic_obj = CreateDictionary

    dic_obj.Add GB_ID, question_cycle_table.t_id
    dic_obj.Add GB_LICENCE, question_cycle_table.license
    dic_obj.Add GB_C_SUB_CATEGORY, question_cycle_table.sub_category
    dic_obj.Add GB_C_TIMES, question_cycle_table.times

    Set question_cycle_table_map = dic_obj

End Function

●common_function
Option Explicit
Function CreateDictionary() As Object

    'ディクショナリーオブジェクトを作成して返却する関数
    
    Dim dicObj As Object
    Set dicObj = CreateObject("Scripting.Dictionary")

    Set CreateDictionary = dicObj

End Function
Function CreateTableList(tableName As String) As Object

    Dim tableList As ListObject
    
    Set tableList = ThisWorkbook.Worksheets(tableName).ListObjects(tableName)

    Set CreateTableList = tableList

End Function

●module1
Option Explicit

'law_info_table
Public Const GB_ID = "ID"
Public Const GB_LICENCE = "licence"
Public Const GB_CATEGORY = "category"
Public Const GB_NUM = "num"
Public Const GB_ROW = "row"
Public Const GB_COL = "col"
Public Const GB_RATE = "rate"
Public Const GB_SUMMARY = "summary"
Public Const GB_DEL_FLG = "del_flg"
Public Const GB_TEXT = "text"
Public Const GB_C_TEXT_NAME = "text_name"
Public Const GB_C_TIMES = "times"
Public Const GB_C_SUB_CATEGORY = "sub_category"


Public Const GB_PLACE = "place"
Public Const GB_WORD = "word"

Public Const GB_T_ID = "t_ID"

Public Const GB_TABLE = "table"

Public Const GB_NUMBER1 = "number1"
Public Const GB_NUMBER2 = "number2"
Public Const GB_NUMBER3 = "number3"

'question_cycle_table
Public Const GB_C_ID = "ID"
Public Const GB_C_SUBJECTS = "subjects"
'Public Const GB_C_CATEGORY = "category"
'Public Const GB_C_TIMES = "times"


Public Const GB_T_LAW_INFO_TABLE = "law_info_table"
Public Const GB_T_FILL_WORD_TABLE = "fill_word_table"
Public Const GB_T_TEMPORARY_TABLE = "temporary_table"
Public Const GB_T_NUMBER_TABLE = "number_table"
Public Const GB_T_QUESTION_CYCLE_TABLE = "question_cycle_table"
Sub create_fill_in_the_blank_character()

    '選択した文字列を穴埋め形式にする(文字列を[]で囲む)
    '[]で囲まれた文字が穴埋め文字列となり、呼び出されたときに解釈される

    Dim rng As Range
    Set rng = Selection
'    Debug.Print (c.Value)

    Dim i As Long
    Dim str As Variant
        
    Application.DisplayAlerts = False
        
    For i = 1 To rng.Count
    
        str = str & rng.Item(i)

    Next i
       
    
    '①一列挿入
    Range(rng.Item(1).Address(False, False)).Insert shift:=xlShiftToRight
    
    'Debug.Print rng.Item(1).Address(False, False)
    
    '②①で挿入した列に識別文字を挿入
    Range(Range(rng.Item(1).Address(False, False)).Offset(0, -1).Address(False, False)).Value = "["

    Range(Range(rng.Item(rng.Count).Address(False, False)).Offset(0, 1).Address(False, False)).Insert shift:=xlShiftToRight
    
    Range(Range(rng.Item(rng.Count).Address(False, False)).Offset(0, 1).Address(False, False)).Value = "]"
    
    'Debug.Print rng.Item(rng.Count).Address(False, False)
    
    
    '以下マージを行う
'    Range(rng.Item(1).Address(False, False) & ":" & rng.Item(rng.Count).Address(False, False)).Merge
'
'    Range(rng.Item(1).Address(False, False)).Value = str
    
    Application.DisplayAlerts = True
    

End Sub
Sub row_insert_1()

    '選択したセルに一列追加
    
    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Selection

    Dim i As Long
    
    For i = 1 To rng.Count
    
'        Debug.Print i & ":" & rng.Item(i).Address(False, False)
        
        Range(rng.Item(i).Address(False, False)).Insert shift:=xlShiftToRight
    
    Next i

    Application.ScreenUpdating = True
            
End Sub
Sub row_delete_1()

    '選択したセルを1列削除

    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Selection

    Dim i As Long
    
'    For i = 1 To rng.Count
'
'        Debug.Print i & ":" & rng.Item(i).Address(False, False)
'
'        Range(rng.Item(i).Address(False, False)).Delete (xlShiftToLeft)
'
'    Next i
    
    '減少カウンタを使う理由
    'https://teratail.com/questions/75463
    
    For i = rng.Count To 1 Step -1
        
        Range(rng.Item(i).Address(False, False)).Delete (xlShiftToLeft)

    Next i

    Application.ScreenUpdating = True
            
End Sub
Sub drow_line()

    '選択したセルの外側に罫線を引く
    
    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Selection
    
    Dim bs As Border

    Set bs = rng.Borders(xlEdgeTop)
    bs.LineStyle = xlContinuous

    Set bs = rng.Borders(xlEdgeBottom)
    bs.LineStyle = xlContinuous
    
    Set bs = rng.Borders(xlEdgeLeft)
    bs.LineStyle = xlContinuous
    
    Set bs = rng.Borders(xlEdgeRight)
    bs.LineStyle = xlContinuous

End Sub
Sub drow_line2()

    '選択したセルの外側に罫線を引く
    '水平線も引く
    
    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Selection
    
    Dim bs As Border

    Set bs = rng.Borders(xlEdgeTop)
    bs.LineStyle = xlContinuous

    Set bs = rng.Borders(xlEdgeBottom)
    bs.LineStyle = xlContinuous
    
    Set bs = rng.Borders(xlEdgeLeft)
    bs.LineStyle = xlContinuous
    
    Set bs = rng.Borders(xlEdgeRight)
    bs.LineStyle = xlContinuous
    
    Set bs = rng.Borders(xlInsideHorizontal)
    bs.LineStyle = xlContinuous

End Sub
Sub delete_line()

    '選択したセルの罫線を削除する
    
    Application.ScreenUpdating = False
    
    Dim rng As Range
    Set rng = Selection
    
    rng.Borders.LineStyle = xlLineStyleNone

End Sub
Function rgist_fill_question(mode As Long)

    'mode1:通常登録
    'mode2:編集登録存在チェックを行わない
    
    Dim newBookName As String
    Dim savepath As String
    Dim newBook As Workbook
    Dim sheetname As String
        
    Dim id As Long
    Dim licence_chara As String
    Dim category_chara As String
    Dim no_chara As String
    Dim row As Long
    Dim col As Long
    Dim t_rate As Long
    Dim summary As String
    
    Dim dic_obj_select_info As Object
    
    Dim select_dto As Object
    
    Dim tbList As ListObject

    If mode = 1 Then
    
        licence_chara = regist_Form.licence_ComboBox.Value
        category_chara = regist_Form.category_ComboBox.Value
        no_chara = regist_Form.no_TextBox
        row = regist_Form.row_TextBox
        col = regist_Form.col_TextBox
        sheetname = licence_chara & "_" & category_chara & "_" & no_chara
        t_rate = regist_Form.rate_ComboBox.ListIndex
        summary = regist_Form.summary_TextBox

        '-------------情報登録-------------
        
        Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
            
       '存在チェックを行う
        dic_obj_select_info.Add GB_LICENCE, licence_chara
        dic_obj_select_info.Add GB_CATEGORY, category_chara
        dic_obj_select_info.Add GB_NUM, no_chara
'        dic_obj_select_info.Add GB_RATE, t_rate
'        dic_obj_search_info.Add GB_SUMMARY, summary
        
        Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
        
        If select_dto.Count > 0 Then
        
            MsgBox "登録済みの問題です。"
            
            End
        
        End If
        
        '情報登録を行う
        Dim dic_obj_insert_info As Object
        Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
        
        
        Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
    
        
        dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1
        dic_obj_insert_info.Add GB_LICENCE, licence_chara
        dic_obj_insert_info.Add GB_CATEGORY, category_chara
        dic_obj_insert_info.Add GB_NUM, no_chara
        dic_obj_insert_info.Add GB_ROW, row
        dic_obj_insert_info.Add GB_COL, col
        dic_obj_insert_info.Add GB_RATE, t_rate
        dic_obj_insert_info.Add GB_SUMMARY, summary
        
        dic_obj_insert_info.Add GB_DEL_FLG, 0
        
        Call insert_info(GB_T_LAW_INFO_TABLE, dic_obj_insert_info, law_info_table_map)
    
    End If
    
    
    If mode = 2 Then
    

        Set dic_obj_select_info = CreateObject("Scripting.Dictionary")

        'テンポラリーテーブルから更新用のIDを取得
        dic_obj_select_info.Add GB_T_ID, 1
        Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)

        id = select_dto.Item(1).Item(GB_ID)
        licence_chara = select_dto.Item(1).Item(GB_LICENCE)
        category_chara = select_dto.Item(1).Item(GB_CATEGORY)
        no_chara = select_dto.Item(1).Item(GB_NUM)
        sheetname = licence_chara & "_" & category_chara & "_" & no_chara
        t_rate = edit_Form.rate_ComboBox.ListIndex
        summary = edit_Form.summary_TextBox

        '行列の更新を行う
        row = edit_Form.row_TextBox
        col = edit_Form.col_TextBox

        '更新条件用の入れ物を用意
        Dim dic_obj_search_info As Object
        Set dic_obj_search_info = CreateObject("Scripting.Dictionary")

        dic_obj_search_info.Add GB_ID, id

        '更新値用の入れ物を用意
        Dim dic_obj_update_info As Object
        Set dic_obj_update_info = CreateObject("Scripting.Dictionary")

        dic_obj_update_info.Add GB_ROW, row
        dic_obj_update_info.Add GB_COL, col
        dic_obj_update_info.Add GB_RATE, t_rate
        dic_obj_update_info.Add GB_SUMMARY, summary

        '更新処理を行う
        Call update_info(GB_T_LAW_INFO_TABLE, dic_obj_search_info, dic_obj_update_info, law_info_table_map)
        
    
    End If
    
    '-------------問題ブック作成-------------
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'ブック作成
    
    newBookName = no_chara & ".xlsx"
    
    savepath = ThisWorkbook.path & "\" & licence_chara & "\" & category_chara & "\" & newBookName
    
'    Debug.Print savepath

    Call DeleteSomething
    
    Set newBook = Workbooks.Add
    
    ThisWorkbook.Activate
    
    If mode = 1 Then

        ThisWorkbook.Worksheets("問題作成").Copy after:=newBook.Sheets(newBook.Sheets.Count)
    
    ElseIf mode = 2 Then
            
        ThisWorkbook.Worksheets("編集").Copy after:=newBook.Sheets(newBook.Sheets.Count)
    
    End If

    newBook.Activate
    
    '1枚目のシート以外は削除する
    
    Dim i As Long

    For i = 1 To Worksheets.Count - 1
    
        newBook.Sheets(i).Delete
        
    Next i

'    newBook.Sheets("Sheet1").Delete
'    newBook.Sheets("Sheet2").Delete
'    newBook.Sheets("Sheet3").Delete
    
    'シート名を変更
    newBook.Sheets(1).Name = sheetname
    
    '不要な行の削除
'    Range("A2", Cells(Rows.Count, 1).End(xlUp)).EntireRow.Delete
    '不要なフォームボタンの削除
    
    Dim myShape As Variant
    
    If Worksheets(sheetname).Shapes.Count > 0 Then
              
        For Each myShape In Worksheets(sheetname).Shapes
        
            '図形がフォームボタンなら削除
            If myShape.Type = msoFormControl Then
            
                myShape.Delete
                
            End If
                
        Next

    End If
    
    newBook.SaveAs savepath
    
    newBook.Close False
    
    Set newBook = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "登録完了です。"
    
    regist_Form.no_TextBox = ""
    regist_Form.row_TextBox = ""
    regist_Form.col_TextBox = ""
    law_Form.law_TextBox = ""
    
    Cells(4, 4).Select

End Function
Sub open_law_Form()

    law_Form.Show vbModeless


End Sub
Sub open_regist_form()

    regist_Form.Show vbModeless

End Sub
Sub open_fill_chara_form()

    fill_chara_Form.Show vbModeless

End Sub
Sub reset_question()
    
    Dim rc As Integer
    Dim myShape As Variant
        
    
    rc = MsgBox("リセットしますか?", vbYesNo + vbQuestion, "確認")
    
    If rc = vbYes Then
        
        'A3行以下、文字、図形を削除
        Call delete_all("A3", "問題作成")
        
'        Range("A3", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
'
'
'        If ThisWorkbook.Worksheets("問題作成").Shapes.Count > 0 Then
'
'            For Each myShape In question_Book.Worksheets(1).Shapes
'
'                myShape.Delete
'
'            Next
'
'        End If
    
    Else
        MsgBox "処理を中断します"
    End If
    
End Sub
Function delete_all(delete_row_range As String, sheet_name As String)
    
    '第一引数:ここで指定した行以下を削除 例 "A3"
    '第二引数:削除を行いたいシート名を指定
    
    
    Dim myShape As Variant
        
    '文字情報を削除する
    Range(delete_row_range, Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
    
    '画像情報を削除する
    If ThisWorkbook.Worksheets(sheet_name).Shapes.Count > 0 Then
              
        For Each myShape In Worksheets(sheet_name).Shapes
            
            'フォームボタンは消さない
            If myShape.Type <> msoFormControl Then
            
                myShape.Delete
                
            End If
            
            'フォームボタンの削除について
            'https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1155987826
            
            
'            If myShape.FormControlType <> xlButtonControl Then
'
'                myShape.Delete
'
'            End If
        
        Next

    End If
    

End Function
Sub test()

    
    '情報登録
    
    Dim dic_obj_select_info As Object
    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
    
    Dim select_dto As Object
    
    '存在チェック
    
    dic_obj_select_info.Add GB_LICENCE, "電験三種"
    dic_obj_select_info.Add GB_CATEGORY, "電技解釈"
    dic_obj_select_info.Add GB_NUM, 1

    Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)

    Debug.Print select_dto.Item(GB_ROW)

End Sub
Sub test_regist()

    Dim dic_obj_insert_info As Object
    Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")

    Dim tbList As ListObject
    Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
    
    
    dic_obj_insert_info.Add GB_LICENCE, "電験三種"
    dic_obj_insert_info.Add GB_CATEGORY, "電技解釈"
    dic_obj_insert_info.Add GB_NUM, "10"
    dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1

    Call insert_info(GB_T_LAW_INFO_TABLE, dic_obj_insert_info, law_info_table_map)

End Sub
Sub test_update()

    Dim dic_obj_update_info As Object
    Set dic_obj_update_info = CreateObject("Scripting.Dictionary")

    Dim dic_obj_search_info As Object
    Set dic_obj_search_info = CreateObject("Scripting.Dictionary")
    
    '検索条件
    dic_obj_search_info.Add GB_CATEGORY, "電技解釈"
'    dic_obj_search_info.Add GB_ID, 3

    '更新値
    dic_obj_update_info.Add GB_NUM, 40
    dic_obj_update_info.Add GB_ROW, 90

    Call update_info(GB_T_LAW_INFO_TABLE, dic_obj_search_info, dic_obj_update_info, law_info_table_map)


End Sub
Sub decompose_string_direct(str)
    
    '入力された文字列をセルに1文字ずつ入れていく
    
    
    Dim i As Long

    Dim row As Long
    Dim col As Long
    
    row = 0
    col = 1
    
    Application.ScreenUpdating = False
    
    
    '前の文字
    Dim current_char As String

    With ActiveCell
    
'        str = .Value
            
        For i = 1 To Len(str)
        
            current_char = Mid(str, i, 1)
            
            If current_char = "/" Then
                
                row = row + 1
                col = 1
            
            Else
          
    
                .Offset(row, col).Value = current_char
                
                col = col + 1
               
            End If
                   
        Next i
  
    End With
    
    Application.ScreenUpdating = True
  
End Sub
Function DeleteSomething()
    'シートコピー前のおまじない
    '何を消してるんだろう?
    Dim C As Name
    
    For Each C In Names
      C.Delete
    Next

End Function
Sub セルに入力された文字列を一文字ずつ横方向に分解する()
    
    '使ってない
    
    Dim str As String
    Dim i As Long

    Dim row As Long
    Dim col As Long

    row = 0
    col = 1
    
    Dim length_linefeed_chara
    '改行文字数
    length_linefeed_chara = 30
    
    Dim linefeed_count As Long
    '改行を行った回数
    linefeed_count = 0
    
    Dim punctuation_mark_flg As Boolean
    '句読点フラグ
    punctuation_mark_flg = False
    
    Dim blank_chara_start As String
    '穴埋め文字が始まるのを判別する文字
    blank_chara_start = "["
    
    Dim blank_chara_end As String
    '穴埋め文字が終わるのを判別する文字
    blank_chara_end = "]"
    
    Dim fill_in_the_blank_chara As String
    
    Dim fill_in_the_blank_chara_count As Long
    
    Dim merge_start As String
    Dim merge_end As String
    
    
    Dim fill_in_the_blank_flg
    '穴埋めフラグ 当フラグがONの場合は改行しない
    fill_in_the_blank_flg = False
    
    Dim pre_char As String
    '前の文字
    Dim current_char As String
    '今の文字
    Dim next_char As String
    '次の文字
    
    Dim active_address_char As String
    
    With ActiveCell
        str = .Value
            
    For i = 1 To Len(str)

        punctuation_mark_flg = False
        current_char = Mid(str, i, 1)
      
        If i > 1 Then
            pre_char = Mid(str, i - 1, 1)
            next_char = Mid(str, i + 1, 1)
                
            
            If current_char = blank_chara_start Then
                
                fill_in_the_blank_flg = True
                
                'ディクショナリを宣言
                Dim dictionary_object_coordinate As Object
                Set dictionary_object_coordinate = CreateObject("Scripting.Dictionary")
                
                fill_in_the_blank_chara_count = 1
                
                
            End If
            
            If fill_in_the_blank_flg = True And current_char = blank_chara_end Then
            
                fill_in_the_blank_flg = False
            
            End If
            
            
            
            
            
            '穴埋めの文字列の間は改行しない
            If fill_in_the_blank_flg = False Then
                
                'イロハニ問答無用で改行
                If current_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ,ル]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
                    
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '漢数字ニ桁で改行
                If current_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) And pre_char Like "[一,ニ,三,四,五,六,七,八,九,十]" Then
                    
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '漢数字一桁で改行
                If current_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
                
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                                           
                    GoTo next_loop
                
                End If
                
                
                If (i > length_linefeed_chara And Not current_char Like "[あ-ん]") And pre_char Like "[あ-ん]" Then
          
                    .Offset(1, 0).Select
                
                    row = row + 1
                    col = 1
                
                
                    If current_char = "、" Or current_char = "。" Then
                
                        punctuation_mark_flg = True
                    
                    End If
                
                    length_linefeed_chara = i + 30
            
                End If
                
             End If
      
        End If
    
next_loop:
    
    If punctuation_mark_flg = False Then
      
        .Offset(row, col).Value = current_char
        
        If fill_in_the_blank_flg = True Then
        
            fill_in_the_blank_chara = fill_in_the_blank_chara + current_char
'            Debug.Print .Offset(row, col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            'ディクショナリに文字座標をブッ込んでいく
            dictionary_object_coordinate.Add fill_in_the_blank_chara_count, .Offset(row, col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        
            fill_in_the_blank_chara_count = fill_in_the_blank_chara_count + 1
        End If
        
        'current_charが"]"だったら、各種処理を行う
        '穴埋めセルの結合
        '穴埋め文字始めの座標の登録
        '穴埋め文字の登録
        'ジャンル(ID、電験三種、電気事業法、一条、予備、予備)座標、穴埋め文字列をセットで登録する
        '一条までは共通、以下座標ごとに個別
      
        If current_char = blank_chara_end Then
        
            merge_start = dictionary_object_coordinate.Item(2)
            merge_end = .Offset(row, col - 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        
            Worksheets("問題展開").Range(merge_start & ":" & merge_end).Merge
            
            Range(dictionary_object_coordinate.Item(2)).Value = Mid(fill_in_the_blank_chara, 2)
            
            merge_start = ""
            merge_end = ""
        
        End If
        
        col = col + 1
       
    End If
    
    
    
    
      
    Next i
  
  End With
  
  Debug.Print Mid(fill_in_the_blank_chara, 2)

End Sub



Sub pattern_test()

    '使用していない
    Dim str As String
    

'    str = "ニ"
'
'    If str Like "[イ,ロ,ハ,ニ]" Then
'
'        Debug.Print str
'
'    End If

    str = "小売供給 一般の需要に"
    
    If InStr(str, "") Then
    
        Debug.Print "全角スペースだぜ"
        
    End If
    



End Sub
Sub merge_cells()

    '使用していない

    Dim a As String
    Dim b As String
    Dim str As String
    
    Range("A1").Select
    
    a = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    
    Worksheets("Sheet1").Range(a & ":B1").Merge
    



End Sub
Function get_kanji(str As String)
            
    '使用していない
            
    Dim kanji_flg As Boolean
    
    kanji_flg = False
    
    Dim kanji As String
    
    
    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "[一-龠〃々〆〇]"
            
    For i = 1 To Len(str)

        current_char = Mid(str, i, 1)
              
        If reg.test(current_char) Then
        
            kanji_flg = True
            
        End If
        
        If reg.test(current_char) = False Then
        
            kanji_flg = False
        
        End If
        
        If kanji_flg = True Then
        
            kanji = kanji + current_char
        
        End If
        
        If kanji_flg = False Then
        
            If Len(kanji) > 1 Then
            
                Debug.Print kanji
                
            
            End If
            
            kanji = ""
         
        
        End If
        
        
        
            
    Next i
  
  


End Function
Sub decompose_string(str)

    '使用していません
    
'    Dim str As String
    Dim i As Long

    Dim row As Long
    Dim col As Long

    row = 0
    col = 1
    
    Dim reg As Object
    
    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "[一-龠〃々〆〇]"
    
    Dim length_linefeed_chara
    '改行文字数
    length_linefeed_chara = 30
    
    Dim linefeed_count As Long
    '改行を行った回数
    linefeed_count = 0
    
    Dim punctuation_mark_flg As Boolean
    '句読点フラグ
    punctuation_mark_flg = False
    
    Dim blank_chara_start As String
    '穴埋め文字が始まるのを判別する文字
    blank_chara_start = "["
    
    Dim blank_chara_end As String
    '穴埋め文字が終わるのを判別する文字
    blank_chara_end = "]"
    
    Dim fill_in_the_blank_chara As String
    
    Dim fill_in_the_blank_chara_count As Long
    
    Dim merge_start As String
    Dim merge_end As String
    
    
    Dim fill_in_the_blank_flg
    '穴埋めフラグ 当フラグがONの場合は改行しない
    fill_in_the_blank_flg = False
    
    Dim pre_char As String
    '前の文字
    Dim current_char As String
    '今の文字
    Dim next_char As String
    '次の文字
    
    Dim next_next_char As String
    '次の次の文字
    
    '次の次の次の文字
    Dim next_next_next_char As String
    
    
    Dim active_address_char As String
    
    With ActiveCell
    
'        str = .Value
            
    For i = 1 To Len(str)

        punctuation_mark_flg = False
        current_char = Mid(str, i, 1)
      
        If i > 1 Then
            pre_char = Mid(str, i - 1, 1)
            next_char = Mid(str, i + 1, 1)
            next_next_char = Mid(str, i + 2, 1)
            next_next_next_char = Mid(str, i + 3, 1)
            
            '穴埋めの文字列の間は改行しない
            If fill_in_the_blank_flg = False Then
                
                'イロハニ問答無用で改行
                If current_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
                    
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 2
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '漢数字三桁で改行
                If current_char Like "[一,二,三,四,五,六,七,八,九]" And next_char Like "[十]" And next_next_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
                    
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '漢数字ニ桁で改行
                If current_char Like "[一,二,三,四,五,六,七,八,九,十]" And next_char Like "[一,二,三,四,五,六,七,八,九,十]" And (InStr(next_next_char, " ") = 1 Or InStr(next_next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
                    
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '漢数字一桁で改行
                If current_char Like "[一,二,三,四,五,六,七,八,九,十]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
                
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 1
                    length_linefeed_chara = i + 30
                                           
                    GoTo next_loop
                
                End If
                
                '(イロハニ)で改行
                If current_char = "(" And next_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ]" And next_next_char = ")" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) Then
                
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 2
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                '(123456789)で改行
                If current_char = "(" And next_char Like "[1,2,3,4,5,6,7,8,9]" And next_next_char = ")" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) Then
                
                    .Offset(1, 0).Select
                    row = row + 1
                    col = 2
                    length_linefeed_chara = i + 30
                    
                    GoTo next_loop
                
                End If
                
                
                If i > length_linefeed_chara And (pre_char = "、" Or pre_char = "。") Then
                
          
                    .Offset(1, 0).Select
                
                    row = row + 1
                    col = 2
                                
                    length_linefeed_chara = i + 30
            
                End If
                
                
                If i > length_linefeed_chara And current_char Like "[あ-ん]" Then
                
          
                    .Offset(1, 0).Select
                
                    row = row + 1
                    col = 2
                
                
                    length_linefeed_chara = i + 30
            
                End If
                
             End If
      
        End If
    
next_loop:

    .Offset(row, col).Value = current_char
       
        If current_char <> "" Then
        
            col = col + 1
        
        End If
        
    Next i
  
  End With
  
End Sub

Sub get_keisen()


    Dim bs As Borders
    Set bs = Range("D16", "AN20").Borders
    Debug.Print (bs.LineStyle)
    Debug.Print (bs.Weight)



End Sub
●module2
Option Explicit
Sub select_question()

    'ランダムで選ばれたブックを開く

    Dim id As Long
    Dim select_dto As Object
    Dim tbList As ListObject
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False


    
    '------------------------超手抜き 連番で攻略したいの
    Dim setter_number As Object
    Dim getter_number As Object
    Dim sequence_flg As Boolean
    Dim setter_number_update As Object
    sequence_flg = False
    Dim sequence_num As Long
    
    Set setter_number = CreateObject("Scripting.Dictionary")
    
    setter_number.Add GB_T_ID, 1
    
    Set getter_number = select_info(GB_T_NUMBER_TABLE, setter_number, number_table_map)
    
    Debug.Print getter_number.Item(1).Item(GB_NUMBER1)
    
    'number_tableの値を0にしておけばランダム出題になる
    If getter_number.Item(1).Item(GB_NUMBER1) > 0 Then
    
        id = getter_number.Item(1).Item(GB_NUMBER1)
        sequence_num = getter_number.Item(1).Item(GB_NUMBER1)
        
        '連番でやる意欲を感じるぜ
        sequence_flg = True
        
        Set setter_number = Nothing
        Set getter_number = Nothing
    
    Else
    
        'ランダム出題
    
        '------------------------law_info_tableから問題呼び出し--------------------------
        
        
        '-------------------------------------------
'        Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
'        Randomize   '乱数系列初期化
'        id = Int(tbList.ListRows.Count * Rnd + 1)
        '-------------------------------------------
        
        
        'idをサイクルで取得する
        Dim obj_subjects As Object
        '科目を決められたサイクルで選び出す
        Set obj_subjects = selectSubjects()
        id = returnRndIdWithCategory(obj_subjects)
    
    End If
    
    '問題情報を各ブックから取得し演習シートにコピペ
    Set select_dto = get_question(id, "演習")
       
    '------------------------temporaryテーブルに問題の情報登録--------------------------
    
    Set tbList = Worksheets(GB_T_TEMPORARY_TABLE).ListObjects(GB_T_TEMPORARY_TABLE)

    '既存情報削除(レコードがない状態で行うとエラー)
    If tbList.ListRows.Count > 0 Then
    
        tbList.DataBodyRange.Delete
    
    End If
    
    '現在展開している問題の把握のため 問題の穴埋め箇所の更新等に利用
    
    Dim dic_obj_insert_info As Object
    Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
    
    dic_obj_insert_info.Add GB_T_ID, 1
    dic_obj_insert_info.Add GB_ID, select_dto.Item(1).Item(GB_ID)
    dic_obj_insert_info.Add GB_LICENCE, select_dto.Item(1).Item(GB_LICENCE)
    dic_obj_insert_info.Add GB_CATEGORY, select_dto.Item(1).Item(GB_CATEGORY)
    dic_obj_insert_info.Add GB_NUM, select_dto.Item(1).Item(GB_NUM)
    dic_obj_insert_info.Add GB_ROW, select_dto.Item(1).Item(GB_ROW)
    dic_obj_insert_info.Add GB_COL, select_dto.Item(1).Item(GB_COL)
    dic_obj_insert_info.Add GB_RATE, select_dto.Item(1).Item(GB_RATE)
    dic_obj_insert_info.Add GB_SUMMARY, select_dto.Item(1).Item(GB_SUMMARY)
    dic_obj_insert_info.Add GB_TEXT, select_dto.Item(1).Item(GB_TEXT)
    
    Call insert_info(GB_T_TEMPORARY_TABLE, dic_obj_insert_info, temporary_table_map)
        
    '------------------------問題解析--------------------------
    
    Sheets("演習").Activate
    
    Call register_fill_in_the_blank_character(select_dto.Item(1).Item(GB_ROW), select_dto.Item(1).Item(GB_COL))
    
    Range("T2").Value = select_dto.Item(1).Item(GB_CATEGORY)
    
    
    Set setter_number = CreateDictionary
    Set setter_number_update = CreateDictionary
    
    '連番で解答したいの
    If sequence_flg = True Then
        
       'カウントアップ
       sequence_num = sequence_num + 1
    
        setter_number.Add (GB_T_ID), 1
        setter_number_update.Add (GB_NUMBER1), sequence_num
    
        Call update_info(GB_T_NUMBER_TABLE, setter_number, setter_number_update, number_table_map)
        
        sequence_flg = False
    
    End If
    
    Dim times As Long
    
    times = select_dto.Item(1).Item(GB_C_TIMES)
    
    'サイクル用に解答回数+1
    Dim setter_target As Object
    Dim setter_value As Object
    
    Set setter_target = CreateDictionary
    Set setter_value = CreateDictionary
    
    setter_target.Add GB_ID, id
    setter_value.Add GB_C_TIMES, times + 1
    
    Call update_info(GB_T_LAW_INFO_TABLE, setter_target, setter_value, law_info_table_map)
    
    'サイクルカウントアップ
    Call updateCycleNO
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Function register_fill_in_the_blank_character(last_row As Long, last_col As Long)

    '[]でくくられている文字とセル座標を取得し登録する


    Dim tbList As ListObject
    Set tbList = Worksheets(GB_T_FILL_WORD_TABLE).ListObjects(GB_T_FILL_WORD_TABLE)
    
    '既存情報削除(レコードがない状態で行うとエラー)
    If tbList.ListRows.Count > 0 Then
    
        tbList.DataBodyRange.Delete
    
    End If
       
    Dim i As Long
    Dim j As Long
    
    Dim fill_flg As Boolean
    
    Dim start_address As String
    
    Dim str As String
    
    fill_flg = False
    
    For i = 1 To last_row
    
        For j = 1 To last_col
            
            
            If fill_flg = True Then
            
                'Debug.Print Cells(i, j).Value
                str = str & Cells(i, j).Value
            
        
            End If
            
            If Cells(i, j).Value = "[" Then
                       
                start_address = Cells(i, j + 1).Address(False, False)
                     
                fill_flg = True
                
                
            End If
            
            
            If Cells(i, j + 1).Value = "]" Then
                            
            
                Range(start_address & ":" & Cells(i, j).Address(False, False)).Merge
            
                Range(start_address).Value = ""
                Range(start_address).Interior.ColorIndex = 19
                
            
                Dim dic_obj_insert_info As Object
                Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
                
                dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1
                dic_obj_insert_info.Add GB_PLACE, start_address
                dic_obj_insert_info.Add GB_WORD, str
            
            
                Call insert_info(GB_T_FILL_WORD_TABLE, dic_obj_insert_info, fill_word_table_map)
                
                start_address = ""
                str = ""
                
                fill_flg = False

            End If
                
        Next j
        
    Next i
        
End Function
Sub edit_question()

    '問題の編集を行う
    'temporaryから問題情報取得
    '問題作成シートに展開

    Dim select_dto As Object
    Dim question_info_dto As Object
    

    Dim dic_obj_select_info As Object
    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")

    '------------------------temporary_table--------------------------
    '一時テーブルから現在展開されている問題情報を取得する
    
    dic_obj_select_info.Add GB_T_ID, 1
    Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
    
    '初期化
    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
    
    '------------------------law_info_table-------------------------
    'law_info_tableから情報を取得する
    
    dic_obj_select_info.Add GB_ID, select_dto.Item(1).Item(GB_ID)
    
    Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
    
    '問題を呼び出す
    Set question_info_dto = get_question(select_dto.Item(1).Item(GB_ID), "編集")
    
    ThisWorkbook.Save
    
    Set question_info_dto = Nothing

End Sub
Function get_question(id As Long, sheet_name As String) As Object

    '問題を呼び出す関数
    '第一引数 id
    '第二引数  呼び出した問題を展開するシート名
    
    '呼ばれるタイミング
    

    Dim question_Book As Workbook
    Dim licence_chara As String
    Dim category_chara As String
    Dim question_path As String
    Dim num As Variant
    Dim row As Long
    Dim col As Long
    
    Dim select_dto As Object

    Dim dic_obj_select_info As Object
    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Worksheets(sheet_name).Activate
    
    '既存削除
'    Worksheets(sheet_name).Range("A3", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
    
    Call delete_all("A3", sheet_name)
    

    dic_obj_select_info.Add GB_ID, id

    Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)

    licence_chara = select_dto.Item(1).Item(GB_LICENCE)
    category_chara = select_dto.Item(1).Item(GB_CATEGORY)
    num = select_dto.Item(1).Item(GB_NUM)
    row = select_dto.Item(1).Item(GB_ROW)
    col = select_dto.Item(1).Item(GB_COL)
    
    question_path = ThisWorkbook.path & "\" & licence_chara & "\" & category_chara & "\" & num
    
    Set question_Book = Workbooks.Open(question_path, 3)

    '文字情報の貼り付け

    question_Book.Worksheets(1).Range(Cells(3, 1), Cells(row, col)).Copy

    ThisWorkbook.Activate
    
    Worksheets(sheet_name).Cells(3, 1).PasteSpecial xlPasteAll
    
    '画像情報の貼り付け
    '穴埋め問題ジェネレーター.xlsmの演習シートが選択されている
    
    Dim myShape As Variant
        
    If question_Book.Worksheets(1).Shapes.Count > 0 Then
            
        For Each myShape In question_Book.Worksheets(1).Shapes
            
            myShape.Copy
            ActiveSheet.Paste
            'myShape.Top+30等で貼り付ける位置を調整できる
            Selection.Top = myShape.Top
            Selection.Left = myShape.Left
        
        Next
    
    End If
    
    Worksheets(sheet_name).Activate
    
    Worksheets(sheet_name).Cells(3, 1).Select
    
    'ThisWorkbook.Save
    
    question_Book.Close savechanges:=False
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set get_question = select_dto
    
End Function
Sub open_edit_form()

    Dim select_dto As Object

    Dim dic_obj_select_info As Object
    Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
    
    Dim t_rate As Long

    dic_obj_select_info.Add GB_T_ID, 1

    Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)

'    Debug.Print select_dto.Item(1).Item(GB_LICENCE)

    edit_Form.licence_TextBox = select_dto.Item(1).Item(GB_LICENCE)
    edit_Form.category_TextBox = select_dto.Item(1).Item(GB_CATEGORY)
    edit_Form.no_TextBox = select_dto.Item(1).Item(GB_NUM)
    edit_Form.row_TextBox = select_dto.Item(1).Item(GB_ROW)
    edit_Form.col_TextBox = select_dto.Item(1).Item(GB_COL)
    edit_Form.rate_ComboBox.ListIndex = select_dto.Item(1).Item(GB_RATE)
    edit_Form.summary_TextBox = select_dto.Item(1).Item(GB_SUMMARY)
    edit_Form.text_TextBox = select_dto.Item(1).Item(GB_TEXT)
    
    edit_Form.licence_TextBox.Enabled = False
    edit_Form.category_TextBox.Enabled = False
    edit_Form.no_TextBox.Enabled = False

    edit_Form.Show vbModeless
    
End Sub
Sub open_text()

    '---------------------temporary_tableからテキストページを取得
    Dim text_page As Long
    Dim setter As Object
    Dim getter As Object
    
    Set setter = CreateObject("Scripting.Dictionary")
    Set getter = CreateObject("Scripting.Dictionary")
    
    setter.Add GB_T_ID, 1
    
    Set getter = select_info(GB_T_TEMPORARY_TABLE, setter, temporary_table_map)
    
    text_page = getter.Item(1).Item(GB_TEXT)


    Dim path As String
    Dim xClip
    Set xClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        
    'クリップボードに開きたいPDFのページ数をコピー
    xClip.SetText text_page
    xClip.PutInClipboard

    'まさかの決め打ち
    path = ThisWorkbook.path & "\電験三種\テキスト\電験三種のエロ本応用編.pdf"
    
    

    'pdfファイルを開く
    With CreateObject("Wscript.Shell")
        .Run path, 5
    End With
    
    With Application
        
        .Wait Now + TimeValue("00:00:01")
        .SendKeys "^+N", True    'CTRL+SHIF+Nを押す
        .Wait Now + TimeValue("00:00:01")
        .SendKeys "^v", True    'CTRL+Vを押す
        .SendKeys "~", True 'エンターを押す
         
    End With





End Sub
Function selectSubjects() As Object
    '決められたサイクルで科目名を返却する
    'サイクル番号はnumber_tableのcycle_noを使う
    Dim setter As Object
    Dim getter_subjects As Object
    Dim getter_cycle_no As Object
    Dim i As Long
    
    Dim dto_subjects
    Set dto_subjects = CreateDictionary
    
    Set setter = CreateDictionary
    'サイクルリストの条件
    setter.Add GB_ID, "*"
    
    'サイクルリストを取得する
    Set getter_subjects = select_info(GB_T_QUESTION_CYCLE_TABLE, setter, question_cycle_table_map)
    
    Set setter = Nothing
    Set setter = CreateDictionary
    
    
'    Debug.Print "selectSubjects.getter_subjects" & getter_subjects.Count
    
    setter.Add GB_T_ID, 1
    
    '現在のサイクル番号を取得する
    Set getter_cycle_no = select_info(GB_T_NUMBER_TABLE, setter, number_table_map)

'    Debug.Print "selectSubjects.getter_cycle_no" & getter_cycle_no.Count

    
    For i = 1 To getter_subjects.Count
    
        If getter_subjects.Item(i).Item(GB_C_ID) = getter_cycle_no.Item(1).Item(GB_NUMBER2) Then
        
            dto_subjects.Add GB_LICENCE, getter_subjects.Item(i).Item(GB_LICENCE)
            dto_subjects.Add GB_C_SUB_CATEGORY, getter_subjects.Item(i).Item(GB_C_SUB_CATEGORY)
            dto_subjects.Add GB_C_TIMES, getter_subjects.Item(i).Item(GB_C_TIMES)
            
'            Debug.Print "資格" & getter_subjects.Item(i).Item(GB_LICENCE)
'            Debug.Print "カテゴリ" & getter_subjects.Item(i).Item(GB_C_SUB_CATEGORY)
'            Debug.Print "回数" & getter_subjects.Item(i).Item(GB_C_TIMES)
            
            Exit For
        
        End If
    
    Next i

    Set selectSubjects = dto_subjects

End Function
Function updateCycleNO()
    
    '今のサイクルNOをカウントアップする
    'サイクル番号はmemory_tableのslot1を使う
    Dim cycleNo As Long
    Dim setter As Object
    Dim setter_target As Object
    Dim setter_value As Object
    Dim getter_subjects As Object
    Dim getter_cycle_no As Object
    
    Set setter = CreateDictionary
    Set setter_target = CreateDictionary
    Set setter_value = CreateDictionary
    
    setter.Add GB_ID, "*"
    
    'サイクルリストを取得する
    Set getter_subjects = select_info(GB_T_QUESTION_CYCLE_TABLE, setter, question_cycle_table_map)
    
    Debug.Print getter_subjects.Count
    
    Set setter = Nothing
    Set setter = CreateDictionary
    
    setter.Add GB_T_ID, 1
    
    '現在のサイクル番号を取得する
    Set getter_cycle_no = select_info(GB_T_NUMBER_TABLE, setter, number_table_map)
    
    If getter_cycle_no.Item(1).Item(GB_NUMBER2) < getter_subjects.Count Then
    
        cycleNo = getter_cycle_no.Item(1).Item(GB_NUMBER2) + 1
        
        setter_target.Add GB_T_ID, 1
        setter_value.Add GB_NUMBER2, cycleNo
    
    Else
    
        cycleNo = 1
        
        setter_target.Add GB_T_ID, 1
        setter_value.Add GB_NUMBER2, cycleNo
        
    
    End If
    
    Call update_info(GB_T_NUMBER_TABLE, setter_target, setter_value, number_table_map)
    

End Function
Function returnRndIdWithCategory(subjects As Object) As Long
    
    '選択科目の問題からランダムにIDを返却する

    Dim setter As Object
    Dim getter As Object
    
    Set setter = CreateDictionary

    '資格名を設定する
    setter.Add GB_LICENCE, subjects.Item(GB_LICENCE)
    
'    Debug.Print "◇名" & subjects.Item(GB_LICENCE)
    
    'カテゴリーが設定されていたら、条件に追加する
    If subjects.Item(GB_C_SUB_CATEGORY) <> "" Then

        setter.Add GB_C_SUB_CATEGORY, subjects.Item(GB_C_SUB_CATEGORY)

    End If

'    Debug.Print "カテゴリ" & subjects.Item(GB_C_SUB_CATEGORY)

    '回数が設定されていたら 未出題に限定したいとき
    If subjects.Item(GB_C_TIMES) <> "" Then

        setter.Add GB_C_TIMES, subjects.Item(GB_C_TIMES)

    End If
    

    
'    MsgBox subjects.Item(GB_C_TIMES)
    
    
    Set getter = select_info(GB_T_LAW_INFO_TABLE, setter, law_info_table_map)
    
    If getter.Count = 0 Then
    
        MsgBox "サイクルモードで科目または、カテゴリー設定に誤りがあります"
        End
    
    End If
    
'    Debug.Print "カウント" & getter.Count
    
    'ランダム番号を取得する
    
    Dim randomNumber As Long
    
    Randomize
    
    randomNumber = Int(getter.Count * Rnd) + 1
    
'    Debug.Print randomNumber
    
    returnRndIdWithCategory = getter.Item(randomNumber).Item(GB_C_ID)
    
End Function
Sub randtest()

    
    Dim tbList As ListObject
    Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)

    
    Randomize   '乱数系列初期化
    Debug.Print Int(tbList.ListRows.Count * Rnd + 1) '1~6で乱数生成



End Sub

Sub longtest()


    Dim a As Long
    Dim b As Long
    
    
    
    
    If IsEmpty(a) Then
        
        Debug.Print "なんもないよ"
    Else
    
        Debug.Print a
    
    End If
     


End Sub

Sub cycle_test()

Dim setter As Object
Dim getter As Object

Set setter = CreateDictionary

setter.Add GB_LICENCE, "消防4類乙"

Set getter = select_info(GB_T_LAW_INFO_TABLE, setter, law_info_table_map)


Debug.Print getter.Count



Debug.Print getter.Count





End Sub


●各ボタン
★問題作成シート
問題作成:open_law_form
穴埋め:open_fill_chara_form
問題登録:open_regist_form
リセット:reset_question
★演習シート
問題ガチャ:select_question
編集:edit_question
テキスト:open_text
★編集シート
問題作成:open_law_form
穴埋め:open_fill_chara_form
再登録する:open_edit_form
問題ガチャ:select_question
テキスト:open_text