だいぶ書いたね・・

Public Function GetAttrSex()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "男"
    Dic1.Add 2, "女"
    Set GetAttrSex = Dic1
End Function
 
Public Function GetAttrPrefectureGroup()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "北海道"
    Dic1.Add 2, "東北"
    Dic1.Add 3, "関東"
    Dic1.Add 4, "信越"
    Dic1.Add 5, "北陸"
    Dic1.Add 6, "東海"
    Dic1.Add 7, "近畿"
    Dic1.Add 8, "中国"
    Dic1.Add 9, "四国"
    Dic1.Add 10, "九州"
    Dic1.Add 11, "沖縄"
    Set GetAttrPrefectureGroup = Dic1
End Function
 
Public Function GetAttrPrefecture()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "北海道"
    Dic1.Add 2, "青森県"
    Dic1.Add 3, "秋田県"
    Dic1.Add 4, "岩手県"
    Dic1.Add 5, "宮城県"
    Dic1.Add 6, "山形県"
    Dic1.Add 7, "福島県"
    Dic1.Add 8, "茨城県"
    Dic1.Add 9, "栃木県"
    Dic1.Add 10, "群馬県"
    Dic1.Add 11, "埼玉県"
    Dic1.Add 12, "千葉県"
    Dic1.Add 13, "東京都"
    Dic1.Add 14, "神奈川県"
    Dic1.Add 15, "山梨県"
    Dic1.Add 16, "長野県"
    Dic1.Add 17, "新潟県"
    Dic1.Add 18, "富山県"
    Dic1.Add 19, "石川県"
    Dic1.Add 20, "福井県"
    Dic1.Add 21, "静岡県"
    Dic1.Add 22, "愛知県"
    Dic1.Add 23, "岐阜県"
    Dic1.Add 24, "三重県"
    Dic1.Add 25, "滋賀県"
    Dic1.Add 26, "京都府"
    Dic1.Add 27, "大阪府"
    Dic1.Add 28, "兵庫県"
    Dic1.Add 29, "奈良県"
    Dic1.Add 30, "和歌山県"
    Dic1.Add 31, "鳥取県"
    Dic1.Add 32, "島根県"
    Dic1.Add 33, "岡山県"
    Dic1.Add 34, "広島県"
    Dic1.Add 35, "山口県"
    Dic1.Add 36, "香川県"
    Dic1.Add 37, "徳島県"
    Dic1.Add 38, "高知県"
    Dic1.Add 39, "愛媛県"
    Dic1.Add 40, "福岡県"
    Dic1.Add 41, "佐賀県"
    Dic1.Add 42, "長崎県"
    Dic1.Add 43, "大分県"
    Dic1.Add 44, "熊本県"
    Dic1.Add 45, "宮崎県"
    Dic1.Add 46, "鹿児島県"
    Dic1.Add 47, "沖縄県"
    Set GetAttrPrefecture = Dic1
End Function
 
Public Function GetAttrMarriage()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "未婚"
    Dic1.Add 2, "既婚"
    Set GetAttrMarriage = Dic1
End Function
 
Public Function GetAttrChild()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "いる"
    Dic1.Add 2, "いない"
    Set GetAttrChild = Dic1
End Function
 
Public Function GetAttrCalling()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "会社員"
    Dic1.Add 2, "公務員"
    Dic1.Add 3, "会社経営者・役員"
    Dic1.Add 4, "自営、商店"
    Dic1.Add 5, "教育、学校関係者"
    Dic1.Add 6, "パート、アルバイト"
    Dic1.Add 7, "派遣"
    Dic1.Add 8, "専業主婦"
    Dic1.Add 9, "無職"
    Dic1.Add 10, "大学、大学院、短大、専門学校"
    Dic1.Add 11, "浪人、予備校生"
    Dic1.Add 12, "高校生"
    Dic1.Add 13, "中学生"
    Dic1.Add 14, "小学生"
    Dic1.Add 15, "その他"
    Set GetAttrCalling = Dic1
End Function
 
Public Function GetAttrIndustry()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "製造業"
    Dic1.Add 2, "商社・卸業"
    Dic1.Add 3, "小売業"
    Dic1.Add 4, "IT関係"
    Dic1.Add 5, "金融業"
    Dic1.Add 6, "建設業"
    Dic1.Add 7, "不動産業"
    Dic1.Add 8, "医療機関"
    Dic1.Add 9, "出版・マスコミ"
    Dic1.Add 10, "通信"
    Dic1.Add 11, "サービス業"
    Dic1.Add 12, "食品・飲料"
    Dic1.Add 13, "アパレル業"
    Dic1.Add 14, "美容・エステ"
    Dic1.Add 15, "運輸業"
    Dic1.Add 16, "教育"
    Dic1.Add 17, "農林・水産業"
    Dic1.Add 18, "自営業"
    Dic1.Add 19, "団体・組合"
    Dic1.Add 20, "製版・印刷業"
    Dic1.Add 21, "広告・企画・デザイン"
    Dic1.Add 22, "宗教法人"
    Dic1.Add 23, "その他"
    Set GetAttrIndustry = Dic1
End Function
 
Public Function GetAttrOccupation()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "営業・販売"
    Dic1.Add 2, "研究・開発・技術者"
    Dic1.Add 3, "総務・人事"
    Dic1.Add 4, "財務・経理"
    Dic1.Add 5, "企画・マーケティング"
    Dic1.Add 6, "広報・広告・デザイン"
    Dic1.Add 7, "その他"
    Dic1.Add 8, "働いていない"
    Set GetAttrOccupation = Dic1
End Function
 
Public Function GetAttrIncome()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "～400万円"
    Dic1.Add 2, "～600万円"
    Dic1.Add 3, "～800万円"
    Dic1.Add 4, "～1000万円"
    Dic1.Add 5, "～1200万円"
    Dic1.Add 6, "～1500万円"
    Dic1.Add 7, "1500万円～"
    Set GetAttrIncome = Dic1
End Function
 
Public Function GetAttrLiving()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "持ち家（一戸建て）"
    Dic1.Add 2, "持ち家（マンション）"
    Dic1.Add 3, "家族持ち家（一戸建て）"
    Dic1.Add 4, "家族持ち家（マンション）"
    Dic1.Add 5, "社宅・寮"
    Dic1.Add 6, "賃貸（一戸建て）"
    Dic1.Add 7, "賃貸（マンション）"
    Dic1.Add 8, "アパート"
    Dic1.Add 9, "公営・公団"
    Dic1.Add 10, "その他"
    Set GetAttrLiving = Dic1
End Function
 
Public Function GetAttrCellular()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "NTT-Docomo(FOMA)"
    Dic1.Add 2, "NTT-Docomo(FOMA以外）"
    Dic1.Add 3, "ソフトバンク（vodafone）"
    Dic1.Add 4, "Tu-ka"
    Dic1.Add 5, "au"
    Dic1.Add 6, "ウィルコム"
    Dic1.Add 7, "PHS"
    Dic1.Add 8, "未使用"
    Set GetAttrCellular = Dic1
End Function
 
Public Function GetAttrInternet()
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add 1, "光ファイバー"
    Dic1.Add 2, "ADSL"
    Dic1.Add 3, "無線インターネット"
    Dic1.Add 4, "ケーブル回線"
    Dic1.Add 5, "ISDN"
    Dic1.Add 6, "ダイヤルアップ"
    Dic1.Add 7, "専用線"
    Dic1.Add 8, "その他／不明"
    Set GetAttrInternet = Dic1
End Function
 
 
 
 
 
Option Explicit
 
'列
Public Const A_ = 1
Public Const B_ = 2
Public Const C_ = 3
Public Const D_ = 4
Public Const E_ = 5
Public Const F_ = 6
Public Const G_ = 7
Public Const H_ = 8
Public Const I_ = 9
Public Const J_ = 10
Public Const K_ = 11
Public Const L_ = 12
Public Const M_ = 13
Public Const N_ = 14
Public Const O_ = 15
Public Const P_ = 16
Public Const Q_ = 17
Public Const R_ = 18
Public Const S_ = 19
Public Const T_ = 20
Public Const U_ = 21
Public Const V_ = 22
Public Const W_ = 23
Public Const X_ = 24
Public Const Y_ = 25
Public Const Z_ = 26
Public Const AA_ = 27
Public Const AB_ = 28
Public Const AC_ = 29
Public Const AD_ = 30
Public Const AE_ = 31
Public Const AF_ = 32
Public Const AG_ = 33
Public Const AH_ = 34
Public Const AI_ = 35
Public Const AJ_ = 36
Public Const AK_ = 37
Public Const AL_ = 38
Public Const AM_ = 39
Public Const AN_ = 40
Public Const AO_ = 41
Public Const AP_ = 42
Public Const AQ_ = 43
Public Const AR_ = 44
Public Const AS_ = 45
Public Const AT_ = 46
Public Const AU_ = 47
Public Const AV_ = 48
Public Const AW_ = 49
Public Const AX_ = 50
Public Const AY_ = 51
Public Const AZ_ = 52
Public Const BA_ = 53
Public Const BB_ = 54
Public Const BC_ = 55
Public Const BD_ = 56
Public Const BE_ = 57
Public Const BF_ = 58
Public Const BG_ = 59
Public Const BH_ = 60
Public Const BI_ = 61
Public Const BJ_ = 62
Public Const BK_ = 63
Public Const BL_ = 64
Public Const BM_ = 65
Public Const BN_ = 66
Public Const BO_ = 67
Public Const BP_ = 68
Public Const BQ_ = 69
Public Const BR_ = 70
Public Const BS_ = 71
Public Const BT_ = 72
Public Const BU_ = 73
Public Const BV_ = 74
Public Const BW_ = 75
Public Const BX_ = 76
Public Const BY_ = 77
Public Const BZ_ = 78
Public Const CA_ = 79
Public Const CB_ = 80
Public Const CC_ = 81
Public Const CD_ = 82
Public Const CE_ = 83
Public Const CF_ = 84
Public Const CG_ = 85
Public Const CH_ = 86
Public Const CI_ = 87
Public Const CJ_ = 88
Public Const CK_ = 89
Public Const CL_ = 90
Public Const CM_ = 91
Public Const CN_ = 92
Public Const CO_ = 93
Public Const CP_ = 94
Public Const CQ_ = 95
Public Const CR_ = 96
Public Const CS_ = 97
Public Const CT_ = 98
Public Const CU_ = 99
Public Const CV_ = 100
Public Const CW_ = 101
Public Const CX_ = 102
Public Const CY_ = 103
Public Const CZ_ = 104
Public Const DA_ = 105
Public Const DB_ = 106
Public Const DC_ = 107
Public Const DD_ = 108
Public Const DE_ = 109
Public Const DF_ = 110
Public Const DG_ = 111
Public Const DH_ = 112
Public Const DI_ = 113
Public Const DJ_ = 114
Public Const DK_ = 115
Public Const DL_ = 116
Public Const DM_ = 117
Public Const DN_ = 118
Public Const DO_ = 119
Public Const DP_ = 120
Public Const DQ_ = 121
Public Const DR_ = 122
Public Const DS_ = 123
Public Const DT_ = 124
Public Const DU_ = 125
Public Const DV_ = 126
Public Const DW_ = 127
Public Const DX_ = 128
Public Const DY_ = 129
Public Const DZ_ = 130
Public Const EA_ = 131
Public Const EB_ = 132
Public Const EC_ = 133
Public Const ED_ = 134
Public Const EE_ = 135
Public Const EF_ = 136
Public Const EG_ = 137
Public Const EH_ = 138
Public Const EI_ = 139
Public Const EJ_ = 140
Public Const EK_ = 141
Public Const EL_ = 142
Public Const EM_ = 143
Public Const EN_ = 144
Public Const EO_ = 145
Public Const EP_ = 146
Public Const EQ_ = 147
Public Const ER_ = 148
Public Const ES_ = 149
Public Const ET_ = 150
Public Const EU_ = 151
Public Const EV_ = 152
Public Const EW_ = 153
Public Const EX_ = 154
Public Const EY_ = 155
Public Const EZ_ = 156
Public Const FA_ = 157
Public Const FB_ = 158
Public Const FC_ = 159
Public Const FD_ = 160
Public Const FE_ = 161
Public Const FF_ = 162
Public Const FG_ = 163
Public Const FH_ = 164
Public Const FI_ = 165
Public Const FJ_ = 166
Public Const FK_ = 167
Public Const FL_ = 168
Public Const FM_ = 169
Public Const FN_ = 170
Public Const FO_ = 171
Public Const FP_ = 172
Public Const FQ_ = 173
Public Const FR_ = 174
Public Const FS_ = 175
Public Const FT_ = 176
Public Const FU_ = 177
Public Const FV_ = 178
Public Const FW_ = 179
Public Const FX_ = 180
Public Const FY_ = 181
Public Const FZ_ = 182
Public Const GA_ = 183
Public Const GB_ = 184
Public Const GC_ = 185
Public Const GD_ = 186
Public Const GE_ = 187
Public Const GF_ = 188
Public Const GG_ = 189
Public Const GH_ = 190
Public Const GI_ = 191
Public Const GJ_ = 192
Public Const GK_ = 193
Public Const GL_ = 194
Public Const GM_ = 195
Public Const GN_ = 196
Public Const GO_ = 197
Public Const GP_ = 198
Public Const GQ_ = 199
Public Const GR_ = 200
Public Const GS_ = 201
Public Const GT_ = 202
Public Const GU_ = 203
Public Const GV_ = 204
Public Const GW_ = 205
Public Const GX_ = 206
Public Const GY_ = 207
Public Const GZ_ = 208
Public Const HA_ = 209
Public Const HB_ = 210
Public Const HC_ = 211
Public Const HD_ = 212
Public Const HE_ = 213
Public Const HF_ = 214
Public Const HG_ = 215
Public Const HH_ = 216
Public Const HI_ = 217
Public Const HJ_ = 218
Public Const HK_ = 219
Public Const HL_ = 220
Public Const HM_ = 221
Public Const HN_ = 222
Public Const HO_ = 223
Public Const HP_ = 224
Public Const HQ_ = 225
Public Const HR_ = 226
Public Const HS_ = 227
Public Const HT_ = 228
Public Const HU_ = 229
Public Const HV_ = 230
Public Const HW_ = 231
Public Const HX_ = 232
Public Const HY_ = 233
Public Const HZ_ = 234
Public Const IA_ = 235
Public Const IB_ = 236
Public Const IC_ = 237
Public Const ID_ = 238
Public Const IE_ = 239
Public Const IF_ = 240
Public Const IG_ = 241
Public Const IH_ = 242
Public Const II_ = 243
Public Const IJ_ = 244
Public Const IK_ = 245
Public Const IL_ = 246
Public Const IM_ = 247
Public Const IN_ = 248
Public Const IO_ = 249
Public Const IP_ = 250
Public Const IQ_ = 251
Public Const IR_ = 252
Public Const IS_ = 253
Public Const IT_ = 254
Public Const IU_ = 255
Public Const IV_ = 256
 
Public Const Q_TYPE_RADIO = 1 'ラジオボタン（単一回答）
Public Const Q_TYPE_CHECK = 2 'チェックボックス（複数回答）
Public Const Q_TYPE_SELECT = 3 'プルダウン（単一回答）
Public Const Q_TYPE_SCALE = 4 'スケール評価（単一回答）
Public Const Q_TYPE_MATRIX_RADIO = 5 'マトリクス質問（単一回答）
Public Const Q_TYPE_MATRIX_CHECK = 6 'マトリクス質問（複数回答）
Public Const Q_TYPE_MATRIX_RADIO_W = 7 '対マトリクス質問（単一回答）
Public Const Q_TYPE_RANK = 8 '順位回答
Public Const Q_TYPE_RATE = 9 '割合
Public Const Q_TYPE_BOX = 10 'フリーアンサー（長文）
Public Const Q_TYPE_TEXT = 11 'フリーアンサー（一行）
 
Public Const Q_NAME_RADIO = "ラジオボタン（単一回答）"
Public Const Q_NAME_CHECK = "チェックボックス（複数回答）"
Public Const Q_NAME_SELECT = "プルダウン（単一回答）"
Public Const Q_NAME_SCALE = "スケール評価（単一回答）"
Public Const Q_NAME_MATRIX_RADIO = "マトリクス質問（単一回答）"
Public Const Q_NAME_MATRIX_CHECK = "マトリクス質問（複数回答）"
Public Const Q_NAME_MATRIX_RADIO_W = "対マトリクス質問（単一回答）"
Public Const Q_NAME_RANK = "順位回答"
Public Const Q_NAME_RATE = "割合"
Public Const Q_NAME_BOX = "フリーアンサー（長文）"
Public Const Q_NAME_TEXT = "フリーアンサー（一行）"
 
'ローデータ書式
Public Const ID_C = A_
Public Const SEX_C = C_
Public Const AGE_C = D_
Public Const AGEID_C = E_
Public Const PREFECTURE_C = F_
Public Const AREA_C = G_
Public Const JOB_C = H_
Public Const CELL_C = I_
Public Const Question_C = H_
 
Public Const RD_TITLE_ROW = 1
Public Const RD_DATA_START_ROW = 2
Public Const RD_START_Q = K_
 
'レイアウト
Public Const LY_Q_NUM_COL = A_
Public Const LY_Q_TITLE_COL = B_
Public Const LY_Q_VALUE = C_
Public Const LY_Q_NAME = D_
Public Const LY_PULL_KEY = E_
Public Const LY_PULL_NAME = F_
Public Const LY_PULL_TYPE = G_
Public Const LY_PULL_COUNT = H_
Public Const LY_PULL_COL = I_
 
Public Const LY_PULL_TYPE_ATTR = 0
 
Public Const ATTR_SEX = "SEX"
Public Const ATTR_PREFECTURE = "PREFECTURE"
Public Const ATTR_AREA = "AREA"
 
 
'テーブル配列用
Public Const GRID_SUM_TITLE_C = "全体"
Public Const GRID_SUM_TITLE_R = "総数"
Public Const GRID_PER_TITLE_R = "（%）"
 
Public Const GRID_SIZE_R = 100
Public Const GRID_SIZE_C = 100
 
Public Const ATTR_GRID_SIZE_R = 3   '表題、総計、パーセント
Public Const ATTR_GRID_TITLE_R = 0
Public Const ATTR_GRID_SUM_R = 1
Public Const ATTR_GRID_PER_R = 2
 
Public Const ATTR_SIZE = 3
 
'GT描画関連
Public Const DRAW_POINT_ROW_START = 2
Public Const DRAW_POINT_COL_START = 2
 
Public Const CELL_HEIGHT = 13.5
Public Const GRAPH_HEIGHT = 24 * CELL_HEIGHT
 
Public Const CELL_WIDTH = 8.38 * 6.375
Public Const GRAPH_WIDTH = 9 * CELL_WIDTH
 
Public Const CELL_WIDTH_PX = 72
 
Public Const GT_TITLE_COLOR_C = 34
Public Const GT_TITLE_COLOR_R = 36
Public Const CR_SUM_COLOR_R = 38
 
Public Const ATTR_GRID_TITLE_C = 0
Public Const ATTR_GRID_SUM_C = 1
Public Const ATTR_GRID_DATA_START_C = 2
Public Const ATTR_GRID_DATA_START_R = 1
 
Public Const GT_TYPE_S = 1
Public Const GT_TYPE_M = 2
 
Public Const TableTypeN = 1
Public Const TableTypeP = 2
 
'クロス
Public Const CR_TOP_TITLE_COL_3 = 4
Public Const CR_TOP_TITLE_COL_2 = 2
Public Const CR_TOP_TITLE = "合計"
 
Public Const LEFT1_TITLE_COL = 0
Public Const LEFT1_SELECT_COL = 1
Public Const LEFT2_TITLE_COL = 2
Public Const LEFT2_SELECT_COL = 3
Public Const LEFT_SUM_COL = 4
Public Const LEFT_SUM_COL_CR2 = LEFT1_SELECT_COL + 1
 
Public Const LEFT_GRID_COL_SIZE_CR3 = 5
Public Const LEFT_GRID_COL_SIZE_CR2 = 3
 
Public Const CR_GRID_HEAD_R = 0
Public Const CR_GRID_TITLE_R = CR_GRID_HEAD_R + 1
Public Const CR_GRID_SUM_R = CR_GRID_TITLE_R + 1
 
Public Const CR_START_R = 2
Public Const CR_START_C = B_
Public Const CR_LEFT1_SELECT_C = CR_START_C
Public Const CR_LEFT1_TITLE_C = CR_LEFT1_SELECT_C + 1
Public Const CR_LEFT2_SELECT_C = CR_LEFT1_TITLE_C + 1
Public Const CR_LEFT2_TITLE_C = CR_LEFT2_SELECT_C + 1
Public Const CR_SUM_C = CR_LEFT2_TITLE_C + 1
Public Const CR_DATA_START_C = CR_SUM_C + 1
 
Public Const CR_SUM_C_CR2 = CR_LEFT1_TITLE_C + 1
Public Const CR_DATA_START_C_CR2 = CR_SUM_C_CR2 + 1
 
 
Public Const CR_LEFT_HEADER_START_R = CR_START_R
Public Const CR_LEFT_SELECT_START_R = CR_LEFT_HEADER_START_R + 1
Public Const CR_LEFT_SUM_START_R = CR_LEFT_SELECT_START_R + 1
Public Const CR_LEFT_TITLE_START_R = CR_LEFT_SUM_START_R + 1
 
Public Const TOP_HEAD_GRID_TITLE_START = 5
Public Const TOP_HEAD_GRID_TITLE_START_CR2 = 3
 
Public Const CR_CELL_WIDTH_PX = 90
Public Const CR_CELL_WIDTH = (((CR_CELL_WIDTH_PX * 72 / 96) - 3.75) / 6)
 
Option Explicit
 
'数字変数
Public a As Integer
Public b As Integer
Public c As Integer
Public D As Integer
Public e As Integer
Public f As Integer
Public g As Integer
Public h As Integer
Public i As Integer
Public j As Integer
Public k As Integer
Public L As Integer
Public m As Integer
Public n As Integer
Public o As Integer
Public p As Integer
Public Q As Integer
Public r As Integer
Public s As Integer
Public t As Integer
Public u As Integer
Public v As Integer
Public w As Integer
Public x As Integer
Public y As Integer
Public z As Integer
 
'文字変数
Public aa As String
Public bb As String
Public cc As String
Public dd As String
Public ee As String
Public ff As String
Public gg As String
Public hh As String
Public ii As String
Public jj As String
Public kk As String
Public ll As String
Public mm As String
Public nn As String
Public oo As String
Public pp As String
Public qq As String
Public rr As String
Public ss As String
Public tt As String
Public uu As String
Public vv As String
Public ww As String
Public xx As String
Public yy As String
Public zz As String
 
'各種フラグ
Public IS_RD As Boolean
Public IS_LY As Boolean
 
 
'ディク
Public Dic1
Public Dic2
Public Dic3
Public Dic4
Public Dic5
 
'split
Public Split1
Public Split2
Public Split3
Public Split4
 
'forach
Public Item1
Public Item2
 
'array
Public Array1(0, 0)
 
Public GraphRowPoint
 
 
'データ加工
Dim PULLS
 
 
Public Function deb(message)
    MsgBox (message)
End Function
 
 
Public Function GetFileName() As String
    Dim OpenFileName As String
    OpenFileName = Application.GetOpenFilename("CSVファイル(*.csv),*.csv")
    If OpenFileName <> "False" Then
        GetFileName = OpenFileName
    Else
        GetFileName = "False"
    End If
End Function
 
Public Function RefSheet(sheetName)
   If chkSheetName(sheetName) Then
        P1_BOOK.Worksheets(sheetName).Delete
   End If
   P1_BOOK.Sheets.Add.Name = sheetName
End Function
 
 
Public Function chkSheetName(sheetName) As Boolean
 
    Dim tempSheet As Object
    chkSheetName = False
    For Each tempSheet In Sheets
        If LCase(sheetName) = LCase(tempSheet.Name) Then
            chkSheetName = True
            Exit For
        End If
    Next tempSheet
 
End Function
 
 
Public Function GetDicSize(Dic)
    z = 0
    For Each Item1 In Dic.keys
        z = z + 1
    Next
    GetDicSize = z
End Function
 
Public Function readCsvFile(targetSheetName) As Boolean
    Dim TargetFile
    TargetFile = GetFileName
    If TargetFile = "False" Then
        readCsvFile = False
        Exit Function
    End If
    Dim FileObj
    RefSheet (targetSheetName)
    Set FileObj = P1_BOOK.Worksheets(targetSheetName)
    With FileObj.QueryTables.Add(Connection:= _
        "TEXT;" & TargetFile, Destination:= _
        Range("A1"))
        .Name = targetSheetName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array( _
            1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1, 1, 1, 1, 1 _
        )
        .Refresh BackgroundQuery:=False
    End With
    readCsvFile = True
End Function
 
 
Public Function WriteRow(sheetObj, Dic, Col, sortFlg)
    Dim Item
    i = 1
    For Each Item In Dic.Items
        sheetObj.Cells(i, Col).Value = Item
        i = i + 1
    Next
    If sortFlg Then
        sheetObj.Range(sheetObj.Cells(1, Col), sheetObj.Cells(i - 1, Col)).Select
        RowSort (sheetObj.Cells(1, Col))
    End If
End Function
 
Public Function RowSort(cel)
    Selection.Sort Key1:=Range(cel, cel), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
End Function
 
Public Function GetYmdHis()
    GetYmdHis = Format(Date, "yyyymmdd") & Format(Now, "hhmmss")
End Function
 
Public Function GetRowSize(TargetSheet, TargetCol)
    y = 1
    Do Until TargetSheet.Cells(y, TargetCol) = ""
        y = y + 1
    Loop
    GetRowSize = y - 1
End Function
 
Public Function WriteBorder(cell1, cell2)
    Range(cell1, cell2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Function
 
 
Public Function init()
    Application.DisplayAlerts = False
    initials
    Set P1_BOOK = Workbooks(P1_BOOK_NAME)
    Set START = P1_BOOK.Worksheets(START_SHEET_NAME)
    MainPanel.Show
End Function
 
 
Public Function initials()
    IS_RD = False
    IS_LY = False
End Function
 
Public Function BackMain()
    START.Activate
End Function
 
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Function initCross()
    MakePull
End Function
 
Public Function MakePull()
    InitCR_1
    InitCR_2
    InitCR_3
End Function
 
Public Function MakeCrBook()
    Workbooks.Add
    CR_BOOK_NAME = ActiveWorkbook.Name
    Set CR_BOOK = Workbooks(CR_BOOK_NAME)
    CR_BOOK.Sheets.Add.Name = CR_TABLE_SHEET
    Set CR_TABLE = CR_BOOK.Worksheets(CR_TABLE_SHEET)
    CR_TABLE.Cells.Select
    Selection.ColumnWidth = 10 'CR_CELL_WIDTH
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
 
End Function
 
Public Function Click_CROSS_SUBMIT()
    Dim CR1
    Dim CR2
    Dim CR3
    CR1 = CrossForm.CR_1.ListIndex
    CR2 = CrossForm.CR_2.ListIndex
    CR3 = CrossForm.CR_3.ListIndex
 
    If CR1 = 0 Or CR3 = 0 Then
        deb "集計するデータを選択してください"
        Exit Function
    End If
'    deb "集計開始"
    MakeCrBook
    If CR3 > 0 And CR2 > 0 And CR1 > 0 Then
        '3重
        MakeCross3 CR1, CR2, CR3
    Else
        '2重
        MakeCross2 CR1, CR3
    End If
 
End Function
 
 
 
Public Function MakeCross2(Left1_Index, Top_Index)
    Dim Left1_Key
    Dim Top_Key
    Dim Left1_Type
    Dim Top_Type
    Dim Left1_Count
    Dim Top_Count
    Dim Left1_Col
    Dim Top_Col
 
    Left1_Key = GetPullKey(Left1_Index)
    Top_Key = GetPullKey(Top_Index)
 
    Left1_Type = GetPullType(Left1_Index)
    Top_Type = GetPullType(Top_Index)
 
    Left1_Count = GetPullCount(Left1_Index)
    Top_Count = GetPullCount(Top_Index)
 
    Left1_Col = GetPullCol(Left1_Index)
    Top_Col = GetPullCol(Top_Index)
 
    Dim DataGrid()
    Dim DataGridRow
    Dim DataGridCol
    DataGridRow = Left1_Count
    DataGridCol = Top_Count
    ReDim DataGrid(DataGridRow - 1, DataGridCol - 1)
 
    Dim L1count
    Dim Topcount
 
    Dim Left1_Dic
    Set Left1_Dic = GetPullSelect(Left1_Key, Left1_Type)
 
    Dim Top_Dic
    Set Top_Dic = GetPullSelect(Top_Key, Top_Type)
 
 
    Dim Left1DicKey
    Dim Left1DicVal
    Dim TopDicKey
    Dim TopDicVal
    Dim Hit
 
    Dim L1_v As String
    Dim Top_v As String
    Dim L1_k As String
    Dim Top_k As String
 
 
    i = 0
    For Each Left1DicKey In Left1_Dic.keys
        Left1DicVal = Left1_Dic(Left1DicKey)
        p = 0
        For Each TopDicKey In Top_Dic.keys
            DataGrid(i, p) = 0
            p = p + 1
        Next
        r = RD_DATA_START_ROW
        Do Until RD.Cells(r, ID_C) = ""
            Top_v = RD.Cells(r, Top_Col)
            L1_k = Left1DicKey
            L1_v = GetMultiValKey(Left1_Type, RD.Cells(r, Left1_Col), L1_k)
            If L1_v = L1_k Then
                p = 0
                For Each TopDicKey In Top_Dic.keys
                    TopDicVal = Top_Dic(TopDicKey)
                    Dim Top_v2
                    aa = TopDicKey
                     Top_v2 = GetMultiValKey(Top_Type, Top_v, aa)
                   If Top_v2 = aa Then
                        s = DataGrid(i, p)
                        DataGrid(i, p) = s + 1
                    End If
                    p = p + 1
                Next
            End If
            r = r + 1
        Loop
        i = i + 1
    Next
 
    Dim HeadGrid()
    ReDim HeadGrid(LEFT_GRID_COL_SIZE_CR2 + GetDicSize(Top_Dic) - 1)
    HeadGrid(TOP_HEAD_GRID_TITLE_START_CR2) = GetPullName(Top_Index)
    HeadGrid(CR_TOP_TITLE_COL_2) = "n"
 
 
    Dim TopGrid()
    ReDim TopGrid(LEFT_GRID_COL_SIZE_CR2 + GetDicSize(Top_Dic) - 1)
    p = CR_TOP_TITLE_COL_2 + 1
    For Each TopDicKey In Top_Dic.keys
        TopDicVal = Top_Dic(TopDicKey)
        TopGrid(p) = TopDicVal
        p = p + 1
    Next
 
    Dim SumGrid()
    ReDim SumGrid(LEFT_GRID_COL_SIZE_CR2 + GetDicSize(Top_Dic) - 1)
    SumGrid(LEFT1_TITLE_COL) = "全体"
    i = 0
    k = 0
    For Each TopDicKey In Top_Dic.keys
        j = 0
        For Each Left1DicKey In Left1_Dic.keys
            Dim SumGridKey
            SumGridKey = i + LEFT_GRID_COL_SIZE_CR2
            If SumGrid(SumGridKey) = "" Then
                SumGrid(SumGridKey) = 0
            End If
            SumGrid(SumGridKey) = SumGrid(SumGridKey) + DataGrid(j, i)
             k = DataGrid(j, i) + k
            j = j + 1
        Next
        i = i + 1
    Next
    SumGrid(LEFT_GRID_COL_SIZE_CR2 - 1) = k
 
    Dim LeftGrid()
    ReDim LeftGrid(DataGridRow, LEFT_GRID_COL_SIZE_CR2 - 1)
 
    i = 0
    For Each Left1DicKey In Left1_Dic.keys
        Left1DicVal = Left1_Dic(Left1DicKey)
        For j = 0 To UBound(LeftGrid, 2)
            If j = LEFT1_TITLE_COL Then
                LeftGrid(i, j) = GetPullName(Left1_Index)
            ElseIf j = LEFT1_SELECT_COL Then
                LeftGrid(i, j) = Left1DicVal
            ElseIf j = LEFT_SUM_COL_CR2 Then
                p = 0
                For o = 0 To UBound(DataGrid, 2)
                     p = DataGrid(i, o) + p
                Next
                LeftGrid(i, j) = p
            End If
        Next
        i = i + 1
    Next
 
 
 
    Dim Grid()
    Dim GridR
    GridR = DataGridRow + 2
    GridC = LEFT_GRID_COL_SIZE_CR2 + GetDicSize(Top_Dic) - 1
    ReDim Grid(GridR, GridC)
 
    For i = 0 To UBound(HeadGrid)
        Grid(CR_GRID_HEAD_R, i) = HeadGrid(i)
    Next
    For i = 0 To UBound(TopGrid)
        Grid(CR_GRID_TITLE_R, i) = TopGrid(i)
    Next
    For i = 0 To UBound(SumGrid)
        Grid(CR_GRID_SUM_R, i) = SumGrid(i)
    Next
    For i = CR_GRID_SUM_R + 1 To UBound(Grid, 1)
        For j = 0 To UBound(Grid, 2)
            If LEFT_GRID_COL_SIZE_CR2 > j Then
                Grid(i, j) = LeftGrid(i - 3, j)
            Else
                Grid(i, j) = DataGrid(i - 3, j - LEFT_GRID_COL_SIZE_CR2)
            End If
        Next
    Next
 
   Dim LastR
   Dim LastC
    For i = 0 To UBound(Grid, 1)
        For j = 0 To UBound(Grid, 2)
          CR_TABLE.Cells(CR_START_R + i, CR_START_C + j) = Grid(i, j)
          LastR = CR_START_R + i
          LastC = CR_START_C + j
        Next
    Next
 
 
 
 
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''
    r = CR_LEFT_TITLE_START_R
 
    With CR_TABLE
        r = CR_LEFT_TITLE_START_R
        c = CR_START_C
        Do Until .Cells(r, CR_START_C) = ""
            r = r + 1
        Loop
        RowSpan .Cells(CR_LEFT_TITLE_START_R, CR_START_C), .Cells(r - 1, CR_START_C)
        .Cells(CR_LEFT_TITLE_START_R, CR_START_C).Interior.ColorIndex = GT_TITLE_COLOR_R
 
 
 
 
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_LEFT1_SELECT_C), .Cells(CR_LEFT_SELECT_START_R, CR_LEFT1_TITLE_C)
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_SUM_C_CR2), .Cells(CR_LEFT_SELECT_START_R, CR_SUM_C_CR2)
 
        r = CR_LEFT_TITLE_START_R
        c = CR_LEFT1_TITLE_C
        Do Until .Cells(r, c) = ""
            .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_C
            r = r + 1
        Loop
        ColSpan .Cells(CR_LEFT_SUM_START_R, CR_LEFT1_SELECT_C), .Cells(CR_LEFT_SUM_START_R, CR_LEFT1_TITLE_C)
        .Cells(CR_LEFT_SUM_START_R, CR_LEFT1_SELECT_C).Interior.ColorIndex = CR_SUM_COLOR_R
 
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C_CR2), .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C_CR2 + GetPullCount(Top_Index) - 1)
        .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C_CR2).Interior.ColorIndex = CR_SUM_COLOR_R
 
        TableBorder .Cells(CR_LEFT_HEADER_START_R, CR_LEFT1_SELECT_C), .Cells(LastR, LastC)
        .Copy After:=Worksheets(CR_TABLE_SHEET)
        Sheets(ActiveSheet.Name).Name = CRP_TABLE_SHEET
        Set CRP_TABLE = CR_BOOK.Worksheets(CRP_TABLE_SHEET)
    End With
    With CRP_TABLE
        For i = CR_LEFT_SUM_START_R To LastR
            For j = CR_DATA_START_C_CR2 To LastC
                a = .Cells(i, j)
                b = .Cells(i, CR_SUM_C_CR2)
                If b > 0 Then
                    .Cells(i, j).Value = a / b
                Else
                    .Cells(i, j).Value = 0
                End If
                .Cells(i, j).Style = "Percent"
                .Cells(i, j).NumberFormatLocal = "0.00%"
            Next
        Next
        Range(.Cells(CR_LEFT_TITLE_START_R, CR_LEFT1_TITLE_C), .Cells(LastR, CR_SUM_C_CR2)).Select
        MakeRightGraph Range(.Cells(CR_LEFT_TITLE_START_R, CR_LEFT1_TITLE_C), .Cells(LastR, CR_SUM_C_CR2)), Left1_Count, _
        10 * 6.375 * LastC - 4, _
        (CELL_HEIGHT) * (CR_LEFT_TITLE_START_R - 1)
    End With
 
 
 
 
 
 
 
 
 
 
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''
 
 
 
 
End Function
 
Public Function GetMultiValKey(QT, RdVal, LyKey)
    If Q_TYPE_MATRIX_CHECK = QT Then
        Split1 = Split(RdVal, "_")
        Dim keys As Integer
        Dim keysL As Integer
        keysL = LyKey
        For keys = 0 To UBound(Split1)
            Dim keys2 As Integer
            Dim val As String
            val = Split1(keys)
            keys2 = keys2 + 1
            If keysL = keys2 And val = 1 Then
                GetMultiValKey = LyKey
                Exit Function
            End If
        Next
        GetMultiValKey = 0
    Else
        GetMultiValKey = RdVal
    End If
End Function
 
 
Public Function MakeCross3(Left1_Index, Left2_Index, Top_Index)
    Dim Left1_Key
    Dim Left2_Key
    Dim Top_Key
    Dim Left1_Type
    Dim Left2_Type
    Dim Top_Type
    Dim Left1_Count
    Dim Left2_Count
    Dim Top_Count
    Dim Left1_Col
    Dim Left2_Col
    Dim Top_Col
 
    Left1_Key = GetPullKey(Left1_Index)
    Left2_Key = GetPullKey(Left2_Index)
    Top_Key = GetPullKey(Top_Index)
 
    Left1_Type = GetPullType(Left1_Index)
    Left2_Type = GetPullType(Left2_Index)
    Top_Type = GetPullType(Top_Index)
 
    Left1_Count = GetPullCount(Left1_Index)
    Left2_Count = GetPullCount(Left2_Index)
    Top_Count = GetPullCount(Top_Index)
 
    Left1_Col = GetPullCol(Left1_Index)
    Left2_Col = GetPullCol(Left2_Index)
    Top_Col = GetPullCol(Top_Index)
 
    Dim DataGrid()
    Dim DataGridRow
    Dim DataGridCol
    DataGridRow = Left1_Count * Left2_Count
    DataGridCol = Top_Count
    ReDim DataGrid(DataGridRow - 1, DataGridCol - 1)
 
    Dim L1count
    Dim L2count
    Dim Topcount
 
    Dim Left1_Dic
    Set Left1_Dic = GetPullSelect(Left1_Key, Left1_Type)
    Dim Left2_Dic
    Set Left2_Dic = GetPullSelect(Left2_Key, Left2_Type)
    Dim Top_Dic
    Set Top_Dic = GetPullSelect(Top_Key, Top_Type)
 
 
    Dim Left1DicKey
    Dim Left1DicVal
    Dim Left2DicKey
    Dim Left2DicVal
    Dim TopDicKey
    Dim TopDicVal
    Dim Hit
 
    Dim L1_v As String
    Dim L2_v As String
    Dim Top_v As String
    Dim L1_k As String
    Dim L2_k As String
    Dim Top_k As String
 
 
    i = 0
    For Each Left1DicKey In Left1_Dic.keys
        Left1DicVal = Left1_Dic(Left1DicKey)
        For Each Left2DicKey In Left2_Dic.keys
            Left2DicVal = Left2_Dic(Left2DicKey)
            p = 0
            For Each TopDicKey In Top_Dic.keys
                DataGrid(i, p) = 0
                p = p + 1
            Next
            r = RD_DATA_START_ROW
            Do Until RD.Cells(r, ID_C) = ""
                Top_v = RD.Cells(r, Top_Col)
                L1_k = Left1DicKey
                L2_k = Left2DicKey
 
                L1_v = GetMultiValKey(Left1_Type, RD.Cells(r, Left1_Col), L1_k)
                L2_v = GetMultiValKey(Left2_Type, RD.Cells(r, Left2_Col), L2_k)
                If L1_v = L1_k And L2_v = L2_k Then
                    p = 0
                    For Each TopDicKey In Top_Dic.keys
                        TopDicVal = Top_Dic(TopDicKey)
                        Dim Top_v2
                        aa = TopDicKey
                         Top_v2 = GetMultiValKey(Top_Type, Top_v, aa)
                       If Top_v2 = aa Then
                            s = DataGrid(i, p)
                            DataGrid(i, p) = s + 1
                        End If
                        p = p + 1
                    Next
                End If
                r = r + 1
            Loop
            i = i + 1
        Next
    Next
 
    Dim HeadGrid()
    ReDim HeadGrid(LEFT_GRID_COL_SIZE_CR3 + GetDicSize(Top_Dic) - 1)
    HeadGrid(TOP_HEAD_GRID_TITLE_START) = GetPullName(Top_Index)
    HeadGrid(CR_TOP_TITLE_COL_3) = "n"
 
 
    Dim TopGrid()
    ReDim TopGrid(LEFT_GRID_COL_SIZE_CR3 + GetDicSize(Top_Dic) - 1)
    p = CR_TOP_TITLE_COL_3 + 1
    For Each TopDicKey In Top_Dic.keys
        TopDicVal = Top_Dic(TopDicKey)
        TopGrid(p) = TopDicVal
        p = p + 1
    Next
 
    Dim SumGrid()
    ReDim SumGrid(LEFT_GRID_COL_SIZE_CR3 + GetDicSize(Top_Dic) - 1)
    SumGrid(LEFT1_TITLE_COL) = "全体"
    i = 0
    k = 0
    For Each TopDicKey In Top_Dic.keys
        j = 0
        For Each Left1DicKey In Left1_Dic.keys
            For Each Left2DicKey In Left2_Dic.keys
                Dim SumGridKey
                SumGridKey = i + LEFT_GRID_COL_SIZE_CR3
                If SumGrid(SumGridKey) = "" Then
                    SumGrid(SumGridKey) = 0
                End If
                SumGrid(SumGridKey) = SumGrid(SumGridKey) + DataGrid(j, i)
                 k = DataGrid(j, i) + k
                j = j + 1
            Next
        Next
        i = i + 1
    Next
    SumGrid(LEFT_GRID_COL_SIZE_CR3 - 1) = k
 
    Dim LeftGrid()
    ReDim LeftGrid(DataGridRow, LEFT_GRID_COL_SIZE_CR3 - 1)
 
    i = 0
    For Each Left1DicKey In Left1_Dic.keys
        Left1DicVal = Left1_Dic(Left1DicKey)
        For Each Left2DicKey In Left2_Dic.keys
            Left2DicVal = Left2_Dic(Left2DicKey)
            For j = 0 To UBound(LeftGrid, 2)
                If j = LEFT1_TITLE_COL Then
                    LeftGrid(i, j) = GetPullName(Left1_Index)
                ElseIf j = LEFT1_SELECT_COL Then
                    LeftGrid(i, j) = Left1DicVal
                ElseIf j = LEFT2_TITLE_COL Then
                    LeftGrid(i, j) = GetPullName(Left2_Index)
                ElseIf j = LEFT2_SELECT_COL Then
                    LeftGrid(i, j) = Left2DicVal
                ElseIf j = LEFT_SUM_COL Then
                    p = 0
                    For o = 0 To UBound(DataGrid, 2)
                         p = DataGrid(i, o) + p
                    Next
                    LeftGrid(i, j) = p
                End If
            Next
            i = i + 1
        Next
    Next
 
 
 
    Dim Grid()
    Dim GridR
    GridR = DataGridRow + 2
    GridC = LEFT_GRID_COL_SIZE_CR3 + GetDicSize(Top_Dic) - 1
    ReDim Grid(GridR, GridC)
 
    For i = 0 To UBound(HeadGrid)
        Grid(CR_GRID_HEAD_R, i) = HeadGrid(i)
    Next
    For i = 0 To UBound(TopGrid)
        Grid(CR_GRID_TITLE_R, i) = TopGrid(i)
    Next
    For i = 0 To UBound(SumGrid)
        Grid(CR_GRID_SUM_R, i) = SumGrid(i)
    Next
    For i = CR_GRID_SUM_R + 1 To UBound(Grid, 1)
        For j = 0 To UBound(Grid, 2)
            If LEFT_GRID_COL_SIZE_CR3 > j Then
                Grid(i, j) = LeftGrid(i - 3, j)
            Else
                Grid(i, j) = DataGrid(i - 3, j - LEFT_GRID_COL_SIZE_CR3)
            End If
        Next
    Next
 
   Dim LastR
   Dim LastC
    For i = 0 To UBound(Grid, 1)
        For j = 0 To UBound(Grid, 2)
          CR_TABLE.Cells(CR_START_R + i, CR_START_C + j) = Grid(i, j)
          LastR = CR_START_R + i
          LastC = CR_START_C + j
        Next
    Next
 
    r = CR_LEFT_TITLE_START_R
 
    With CR_TABLE
        r = CR_LEFT_TITLE_START_R
        c = CR_START_C
        Do Until .Cells(r, CR_START_C) = ""
            r = r + 1
        Loop
        RowSpan .Cells(CR_LEFT_TITLE_START_R, CR_START_C), .Cells(r - 1, CR_START_C)
        .Cells(CR_LEFT_TITLE_START_R, CR_START_C).Interior.ColorIndex = GT_TITLE_COLOR_R
        r = CR_LEFT_TITLE_START_R
        c = CR_LEFT1_TITLE_C
        For Each Left1DicKey In Left1_Dic.keys
            s = r
            r = r + GetDicSize(Left2_Dic)
            e = r - 1
            RowSpan .Cells(s, c), .Cells(e, c)
            .Cells(s, c).Interior.ColorIndex = GT_TITLE_COLOR_R
        Next
        r = CR_LEFT_TITLE_START_R
        c = CR_LEFT2_SELECT_C
        For Each Left1DicKey In Left1_Dic.keys
            s = r
            r = r + GetDicSize(Left2_Dic)
            e = r - 1
            RowSpan .Cells(s, c), .Cells(e, c)
            .Cells(s, c).Interior.ColorIndex = GT_TITLE_COLOR_C
        Next
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_LEFT1_SELECT_C), .Cells(CR_LEFT_SELECT_START_R, CR_LEFT2_TITLE_C)
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_SUM_C), .Cells(CR_LEFT_SELECT_START_R, CR_SUM_C)
 
        r = CR_LEFT_TITLE_START_R
        c = CR_LEFT2_TITLE_C
        Do Until .Cells(r, c) = ""
            .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_C
            r = r + 1
        Loop
        ColSpan .Cells(CR_LEFT_SUM_START_R, CR_LEFT1_SELECT_C), .Cells(CR_LEFT_SUM_START_R, CR_LEFT2_TITLE_C)
        .Cells(CR_LEFT_SUM_START_R, CR_LEFT1_SELECT_C).Interior.ColorIndex = CR_SUM_COLOR_R
 
        ColSpan .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C), .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C + GetPullCount(Top_Index) - 1)
        .Cells(CR_LEFT_HEADER_START_R, CR_DATA_START_C).Interior.ColorIndex = CR_SUM_COLOR_R
 
        TableBorder .Cells(CR_LEFT_HEADER_START_R, CR_LEFT1_SELECT_C), .Cells(LastR, LastC)
        .Copy After:=Worksheets(CR_TABLE_SHEET)
        Sheets(ActiveSheet.Name).Name = CRP_TABLE_SHEET
        Set CRP_TABLE = CR_BOOK.Worksheets(CRP_TABLE_SHEET)
    End With
    With CRP_TABLE
        For i = CR_LEFT_SUM_START_R To LastR
            For j = CR_DATA_START_C To LastC
                a = .Cells(i, j)
                b = .Cells(i, CR_SUM_C)
                If b > 0 Then
                    .Cells(i, j).Value = a / b
                Else
                    .Cells(i, j).Value = 0
                End If
                .Cells(i, j).Style = "Percent"
                .Cells(i, j).NumberFormatLocal = "0.00%"
            Next
        Next
        Range(.Cells(CR_LEFT_TITLE_START_R, CR_LEFT2_TITLE_C), .Cells(LastR, CR_SUM_C)).Select
        MakeRightGraph Range(.Cells(CR_LEFT_TITLE_START_R, CR_LEFT2_TITLE_C), .Cells(LastR, CR_SUM_C)), Left1_Count * Left2_Count, _
        10 * 6.375 * LastC - 4, _
        (CELL_HEIGHT) * (CR_LEFT_TITLE_START_R - 1)
    End With
 
 
End Function
 
Public Function MakeRightGraph(TARGET, dataSizeR, left, top)
    Dim Title
    Title = "ぐらふ"
    CRP_TABLE.ChartObjects.Add(left, top - 3.75, GRAPH_WIDTH, CELL_HEIGHT * dataSizeR + 3.75 + 5).Name = Title
    Dim Ch
    Set Ch = CRP_TABLE.ChartObjects(Title).Chart
    With Ch
        .ChartType = xlBarClustered
        .SetSourceData Source:=TARGET, PlotBy _
             :=xlColumns
    End With
    With Ch.Axes(xlCategory)
        .AxisBetweenCategories = True
        .ReversePlotOrder = True
    End With
    With Ch
        .HasAxis(xlCategory, xlPrimary) = False
        .HasAxis(xlValue, xlPrimary) = False
    End With
    Ch.Axes(xlCategory, xlPrimary).CategoryType = xlAutomatic
    With Ch.Axes(xlCategory)
        .HasMajorGridlines = False
        .HasMinorGridlines = False
    End With
    With Ch.Axes(xlValue)
        .HasMajorGridlines = False
        .HasMinorGridlines = False
    End With
    Ch.HasLegend = False
    Ch.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False
    With Ch.PlotArea
        .left = 1
        .top = 1
        .Height = (CELL_HEIGHT + 0.25) * dataSizeR
    End With
    With Ch.ChartArea.Border
        .Weight = 1
        .LineStyle = 0
    End With
    With Ch.ChartGroups(1)
        .Overlap = 0
        .GapWidth = 0
        .HasSeriesLines = False
    End With
    Ch.ChartArea.AutoScaleFont = True
    With Ch.ChartArea.Font
        .Size = 8
    End With
    With Ch.ChartGroups(1)
        .Overlap = 0
        .GapWidth = 0
        .HasSeriesLines = False
        .VaryByCategories = True
    End With
    With Ch.SeriesCollection(1).DataLabels
        .AutoScaleFont = True
    End With
    With Ch.SeriesCollection(1).DataLabels.Font
        .Size = 8
    End With
 
 
    Ch.PlotArea.Interior.ColorIndex = xlNone
    Ch.ChartArea.Interior.ColorIndex = xlNone
End Function
 
Public Function ColSpan(cell1, cell2)
    CR_TABLE.Range(cell1, cell2).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .MergeCells = True
    End With
End Function
 
Public Function RowSpan(cell1, cell2)
    CR_TABLE.Range(cell1, cell2).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = xlVertical
        .AddIndent = False
        .ShrinkToFit = True
        .MergeCells = True
    End With
End Function
 
Public Function GetPullSelect(key, ty)
    Set Dic2 = CreateObject("Scripting.Dictionary")
    If LY_PULL_TYPE_ATTR = ty Then
        If key = ATTR_SEX Then
            Set Dic2 = GetAttrSex
        ElseIf key = ATTR_PREFECTURE Then
            Set Dic2 = GetAttrPrefecture
        ElseIf key = ATTR_AREA Then
            Set Dic2 = GetAttrPrefectureGroup
        End If
    Else
        r = 1
        Do Until LY.Cells(r, LY_Q_NUM_COL) = ""
            If LY.Cells(r, LY_Q_NUM_COL) = key And Dic2.Exists(cc) = False Then
                aa = LY.Cells(r, LY_Q_VALUE)
                bb = LY.Cells(r, LY_Q_NAME)
                Dic2.Add aa, bb
            End If
            r = r + 1
        Loop
    End If
    Set GetPullSelect = Dic2
End Function
 
Public Function GetPullCol(index)
    GetPullCol = LY.Cells(index, LY_PULL_COL)
End Function
 
Public Function GetPullCount(index)
    GetPullCount = LY.Cells(index, LY_PULL_COUNT)
End Function
 
Public Function GetPullKey(index)
    GetPullKey = LY.Cells(index, LY_PULL_KEY)
End Function
 
Public Function GetPullType(index)
    GetPullType = LY.Cells(index, LY_PULL_TYPE)
End Function
 
Public Function GetPullName(index)
    GetPullName = LY.Cells(index, LY_PULL_NAME)
End Function
 
 
 
 
Public Function InitCR_1()
    r = 1
    With CrossForm.CR_1
        .Clear
        .AddItem "表題1を選択"
        Do Until LY.Cells(r, LY_PULL_NAME) = ""
             .AddItem LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
             r = r + 1
        Loop
        .ListIndex = 0
    End With
End Function
 
Public Function InitCR_2()
    r = 1
    With CrossForm.CR_2
        .Clear
        .AddItem "表題2を選択"
        Do Until LY.Cells(r, LY_PULL_NAME) = ""
             .AddItem LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
             r = r + 1
        Loop
        .ListIndex = 0
        .Enabled = False
    End With
End Function
 
Public Function InitCR_3()
    r = 1
    With CrossForm.CR_3
        .Clear
        .AddItem "表頭を選択"
        Do Until LY.Cells(r, LY_PULL_NAME) = ""
             .AddItem LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
             r = r + 1
        Loop
        .ListIndex = 0
    End With
End Function
Public Function Change_CR_1()
    With CrossForm.CR_1
        i = .ListIndex
        If i > 0 Then
            CrossForm.CR_2.Enabled = True
        Else
           InitCR_2
        End If
    End With
End Function
Public Function Change_CR_2()
 
End Function
 
Public Function Change_CR_3()
 
End Function
 
 
Public Function TableBorder(cell1, cell2)
    Range(cell1, cell2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Function
 
Public Function initData()
    InitTARGET_1
    MakeNewData
End Function
 
 
 
 
Public Function InitTARGET_1()
    r = 1
    Set PULLS = CreateObject("Scripting.Dictionary")
    With DataForm.TARGET_1
        .Clear
        .AddItem "対象を選択"
        Do Until LY.Cells(r, LY_PULL_NAME) = ""
            PULLS.Add r, LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
             .AddItem LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
             r = r + 1
        Loop
        .ListIndex = 0
    End With
End Function
 
Public Function MakeNewData()
 
End Function
 
Public Function Click_ClassMake()
    Dim T1
    T1 = DataForm.TARGET_1.ListIndex
    If T1 = 0 Then
        deb "対象を選択してください"
        Exit Function
    End If
 
    Set PULLS = CreateObject("Scripting.Dictionary")
    r = 1
    Do Until LY.Cells(r, LY_PULL_NAME) = ""
        PULLS.Add r, LY.Cells(r, LY_PULL_NAME) & "(" & LY.Cells(r, LY_PULL_COUNT) & ")"
        r = r + 1
    Loop
 
    ClassForm.CLASS_TITLE.Caption = PULLS(T1)
    ClassForm.Show
End Function
 
Public Function Click_ADD_CLASS()
    If CheckScale = False Then
        Exit Function
    End If
    Dim TARGET
    TARGET = DataForm.TARGET_1.ListIndex
    Dim NEW_TITLE As String
    NEW_TITLE = ClassForm.NEW_TITLE.Value
    Dim T1 As String
    Dim T2 As String
    Dim T3 As String
    Dim T4 As String
    Dim T5 As String
    Dim T6 As String
    Dim T7 As String
    Dim T8 As String
    Dim T9 As String
    Dim T10 As String
    Dim D1 As Long
    Dim D2 As Long
    Dim D3 As Long
    Dim D4 As Long
    Dim D5 As Long
    Dim D6 As Long
    Dim D7 As Long
    Dim D8 As Long
    Dim D9 As Long
    Dim D10 As Long
    Dim U1 As Long
    Dim U2 As Long
    Dim U3 As Long
    Dim U4 As Long
    Dim U5 As Long
    Dim U6 As Long
    Dim U7 As Long
    Dim U8 As Long
    Dim U9 As Long
    Dim U10 As Long
 
    With ClassForm
        T1 = .SCALE_TITLE_1.Text
        If .SCALE_DOWN_1.Text <> "" Then
            D1 = .SCALE_DOWN_1.Text
        End If
 
        If .SCALE_UP_1.Text <> "" Then
            U1 = .SCALE_UP_1.Text
        End If
 
        T2 = .SCALE_TITLE_2.Text
        If .SCALE_DOWN_2.Text <> "" Then
            D2 = .SCALE_DOWN_2.Text
        End If
 
        If .SCALE_UP_2.Text <> "" Then
            U2 = .SCALE_UP_2.Text
        End If
        T3 = .SCALE_TITLE_3.Text
 
        If .SCALE_DOWN_3.Text <> "" Then
            D3 = .SCALE_DOWN_3.Text
        End If
 
        If .SCALE_UP_3.Text <> "" Then
            U3 = .SCALE_UP_3.Text
        End If
        T4 = .SCALE_TITLE_4.Text
 
        If .SCALE_DOWN_4.Text <> "" Then
            D4 = .SCALE_DOWN_4.Text
        End If
 
        If .SCALE_UP_4.Text <> "" Then
            U4 = .SCALE_UP_4.Text
        End If
        T5 = .SCALE_TITLE_5.Text
 
        If .SCALE_DOWN_5.Text <> "" Then
            D5 = .SCALE_DOWN_5.Text
        End If
 
        If .SCALE_UP_5.Text <> "" Then
            U5 = .SCALE_UP_5.Text
        End If
        T6 = .SCALE_TITLE_6.Text
 
        If .SCALE_DOWN_6.Text <> "" Then
            D6 = .SCALE_DOWN_6.Text
        End If
 
        If .SCALE_UP_6.Text <> "" Then
            U6 = .SCALE_UP_6.Text
        End If
        T7 = .SCALE_TITLE_7.Text
 
        If .SCALE_DOWN_7.Text <> "" Then
            D7 = .SCALE_DOWN_7.Text
        End If
 
        If .SCALE_UP_7.Text <> "" Then
            U7 = .SCALE_UP_7.Text
        End If
        T8 = .SCALE_TITLE_8.Text
 
        If .SCALE_DOWN_8.Text <> "" Then
            D8 = .SCALE_DOWN_8.Text
        End If
 
        If .SCALE_UP_8.Text <> "" Then
            U8 = .SCALE_UP_8.Text
        End If
        T9 = .SCALE_TITLE_9.Text
 
        If .SCALE_DOWN_9.Text <> "" Then
            D9 = .SCALE_DOWN_9.Text
        End If
 
        If .SCALE_UP_9.Text <> "" Then
            U9 = .SCALE_UP_9.Text
        End If
 
        T10 = .SCALE_TITLE_10.Text
        If .SCALE_DOWN_10.Text <> "" Then
            D10 = .SCALE_DOWN_10.Text
        End If
 
        If .SCALE_UP_10.Text <> "" Then
            U10 = .SCALE_UP_10.Text
        End If
 
    End With
    Dim NextQ As Integer
    NextQ = GetNextQ
    deb "next - " & NextQ
    r = 1
    Do Until LY.Cells(r, LY_Q_NUM_COL) = ""
        r = r + 1
    Loop
    Dim counts
    counts = 0
    If T1 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 1
        LY.Cells(r, LY_Q_NAME) = T1
        counts = counts + 1
        r = r + 1
    End If
    If T2 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 2
        LY.Cells(r, LY_Q_NAME) = T2
        counts = counts + 1
        r = r + 1
    End If
    If T3 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 3
        LY.Cells(r, LY_Q_NAME) = T3
        counts = counts + 1
        r = r + 1
    End If
    If T4 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 4
        LY.Cells(r, LY_Q_NAME) = T4
        counts = counts + 1
        r = r + 1
    End If
    If T5 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 5
        LY.Cells(r, LY_Q_NAME) = T5
        counts = counts + 1
        r = r + 1
    End If
    If T6 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 6
        LY.Cells(r, LY_Q_NAME) = T6
        counts = counts + 1
        r = r + 1
    End If
    If T7 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 7
        LY.Cells(r, LY_Q_NAME) = T7
        counts = counts + 1
        r = r + 1
    End If
    If T8 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 8
        LY.Cells(r, LY_Q_NAME) = T8
        counts = counts + 1
        r = r + 1
    End If
    If T9 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 9
        LY.Cells(r, LY_Q_NAME) = T9
        counts = counts + 1
        r = r + 1
    End If
    If T10 <> "" Then
        LY.Cells(r, LY_Q_NUM_COL) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
        LY.Cells(r, LY_Q_TITLE_COL) = "Q" & NextQ & " " & NEW_TITLE
        LY.Cells(r, LY_Q_VALUE) = 10
        LY.Cells(r, LY_Q_NAME) = T10
        counts = counts + 1
        r = r + 1
    End If
    r = 1
    Do Until LY.Cells(r, LY_PULL_KEY) = ""
        r = r + 1
    Loop
    LY.Cells(r, LY_PULL_KEY) = "Q" & NextQ & "_" & Q_TYPE_RADIO & "_1"
    LY.Cells(r, LY_PULL_NAME) = "Q" & NextQ & " " & NEW_TITLE
    LY.Cells(r, LY_PULL_TYPE) = Q_TYPE_RADIO
    LY.Cells(r, LY_PULL_COUNT) = counts
    c = 1
    Do Until RD.Cells(RD_TITLE_ROW, c) = ""
        c = c + 1
    Loop
    LY.Cells(r, LY_PULL_COL) = c
 
End Function
 
 
Public Function GetNextQ()
    i = 2
    j = 0
    Do Until TMP.Cells(i, Question_C) = ""
        aa = TMP.Cells(i, Question_C)
        Split1 = Split(aa, "Q")
        j = Split1(1)
        i = i + 1
    Loop
    If j > 0 Then
        j = j + 1
        GetNextQ = j
    Else
        GetNextQ = 1
    End If
End Function
 
Public Function CheckScale()
    Dim message As String
    message = ""
 
    With ClassForm
        If .NEW_TITLE.Text = "" Then
            message = message & "質問内容が未入力です" & vbCrLf
        End If
        If .SCALE_TITLE_1.Text = "" Then
            message = message & "1つめの選択肢が未入力です" & vbCrLf
        End If
        If IsNumeric(.SCALE_DOWN_1.Text) = False And .SCALE_DOWN_1.Text <> "" Then
            message = message & "1つめの下限が数字じゃありません" & vbCrLf
        End If
        If IsNumeric(.SCALE_UP_1.Text) = False And .SCALE_UP_1.Text <> "" Then
            message = message & "1つめの上限が数字じゃありません" & vbCrLf
        End If
 
        If .SCALE_TITLE_2.Text <> "" Or .SCALE_DOWN_2.Text <> "" Or .SCALE_UP_2.Text <> "" Then
            If .SCALE_UP_1.Text = "" Then
                message = message & "1つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_2.Text = "" Then
                message = message & "2つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_2.Text) = False Or .SCALE_DOWN_2.Text = "" Then
                message = message & "2つめの下限が正しくありません" & vbCrLf
            ElseIf CInt(.SCALE_UP_1.Text) >= CInt(.SCALE_DOWN_2.Text) Then
                message = message & "2つめの下限が1つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_2.Text) = False And .SCALE_UP_2.Text <> "" Then
                message = message & "2つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_3.Text <> "" Or .SCALE_DOWN_3.Text <> "" Or .SCALE_UP_3.Text <> "" Then
            If .SCALE_UP_2.Text = "" Then
                message = message & "2つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_3.Text = "" Then
                message = message & "3つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_3.Text) = False Or .SCALE_DOWN_3.Text = "" Then
                message = message & "3つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_2.Text >= .SCALE_DOWN_3.Text Then
                message = message & "3つめの下限が2つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_3.Text) = False And .SCALE_UP_3.Text <> "" Then
                message = message & "3つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_4.Text <> "" Or .SCALE_DOWN_4.Text <> "" Or .SCALE_UP_4.Text <> "" Then
            If .SCALE_UP_3.Text = "" Then
                message = message & "3つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_4.Text = "" Then
                message = message & "4つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_4.Text) = False Or .SCALE_DOWN_4.Text = "" Then
                message = message & "4つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_3.Text >= .SCALE_DOWN_4.Text Then
                message = message & "4つめの下限が3つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_4.Text) = False And .SCALE_UP_4.Text <> "" Then
                message = message & "4つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_5.Text <> "" Or .SCALE_DOWN_5.Text <> "" Or .SCALE_UP_5.Text <> "" Then
            If .SCALE_UP_4.Text = "" Then
                message = message & "4つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_5.Text = "" Then
                message = message & "5つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_5.Text) = False Or .SCALE_DOWN_5.Text = "" Then
                message = message & "5つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_4.Text >= .SCALE_DOWN_5.Text Then
                message = message & "5つめの下限が4つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_5.Text) = False And .SCALE_UP_5.Text <> "" Then
                message = message & "5つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_6.Text <> "" Or .SCALE_DOWN_6.Text <> "" Or .SCALE_UP_6.Text <> "" Then
            If .SCALE_UP_5.Text = "" Then
                message = message & "5つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_6.Text = "" Then
                message = message & "6つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_6.Text) = False Or .SCALE_DOWN_6.Text = "" Then
                message = message & "6つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_5.Text >= .SCALE_DOWN_6.Text Then
                message = message & "6つめの下限が5つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_6.Text) = False And .SCALE_UP_6.Text <> "" Then
                message = message & "6つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_7.Text <> "" Or .SCALE_DOWN_7.Text <> "" Or .SCALE_UP_7.Text <> "" Then
            If .SCALE_UP_6.Text = "" Then
                message = message & "6つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_7.Text = "" Then
                message = message & "7つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_7.Text) = False Or .SCALE_DOWN_7.Text = "" Then
                message = message & "7つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_6.Text >= .SCALE_DOWN_7.Text Then
                message = message & "7つめの下限が6つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_7.Text) = False And .SCALE_UP_7.Text <> "" Then
                message = message & "7つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_8.Text <> "" Or .SCALE_DOWN_8.Text <> "" Or .SCALE_UP_8.Text <> "" Then
            If .SCALE_UP_7.Text = "" Then
                message = message & "7つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_8.Text = "" Then
                message = message & "8つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_8.Text) = False Or .SCALE_DOWN_8.Text = "" Then
                message = message & "8つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_7.Text >= .SCALE_DOWN_8.Text Then
                message = message & "8つめの下限が7つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_8.Text) = False And .SCALE_UP_8.Text <> "" Then
                message = message & "8つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_9.Text <> "" Or .SCALE_DOWN_9.Text <> "" Or .SCALE_UP_9.Text <> "" Then
            If .SCALE_UP_8.Text = "" Then
                message = message & "8つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_9.Text = "" Then
                message = message & "9つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_9.Text) = False Or .SCALE_DOWN_9.Text = "" Then
                message = message & "9つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_8.Text >= .SCALE_DOWN_9.Text Then
                message = message & "9つめの下限が8つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_9.Text) = False And .SCALE_UP_9.Text <> "" Then
                message = message & "9つめの上限が正しくありません" & vbCrLf
            End If
        End If
        If .SCALE_TITLE_10.Text <> "" Or .SCALE_DOWN_10.Text <> "" Or .SCALE_UP_10.Text <> "" Then
            If .SCALE_UP_9.Text = "" Then
                message = message & "9つめの上限が未入力です" & vbCrLf
            End If
            If .SCALE_TITLE_10.Text = "" Then
                message = message & "10つめの選択肢が未入力です" & vbCrLf
            End If
            If IsNumeric(.SCALE_DOWN_10.Text) = False Or .SCALE_DOWN_10.Text = "" Then
                message = message & "10つめの下限が正しくありません" & vbCrLf
            ElseIf .SCALE_UP_9.Text >= .SCALE_DOWN_10.Text Then
                message = message & "10つめの下限が9つめの上限より小さいです" & vbCrLf
            End If
            If IsNumeric(.SCALE_UP_10.Text) = False And .SCALE_UP_10.Text <> "" Then
                message = message & "10つめの上限が正しくありません" & vbCrLf
            End If
        End If
    End With
    If message <> "" Then
        deb message
        CheckScale = False
    Else
        CheckScale = True
    End If
 
End Function
 
Public Function Change_TARGET_1()
    Dim T1
    T1 = DataForm.TARGET_1.ListIndex
    If T1 = 0 Then
        Exit Function
    End If
'    deb T1
End Function
 
Public Function MakeGtData() As Boolean
    Dim Grids()
    ReDim Grids(ATTR_SIZE)
    Grids(0) = MakeGtGrid("性別", GetAttrSex, SEX_C)
    Grids(1) = MakeGtGrid("都道府県", GetAttrPrefecture, PREFECTURE_C)
    Grids(2) = MakeGtGrid("地域", GetAttrPrefectureGroup, AREA_C)
    MakeGtBook
    GT_BOOK.Sheets.Add.Name = GT_TABLE_SHEET
    Set GT_TABLE = GT_BOOK.Worksheets(GT_TABLE_SHEET)
    GT_BOOK.Sheets.Add.Name = GT_GRAPH_SHEET
    Set GT_GRAPH = GT_BOOK.Worksheets(GT_GRAPH_SHEET)
 
    Dim RowPoint
    RowPoint = DrawTableAttr(Grids)
 
    MakeGtDataQ (RowPoint)
 
    MakeGtData = True
    BackMain
End Function
 
Public Function DrawTableAttr(Grids)
    Dim DrawPointRow As Integer
    Dim DrawPointCol As Integer
    DrawPointRow = DRAW_POINT_ROW_START
    DrawPointCol = DRAW_POINT_COL_START
 
    Dim GraphTitlePointStartRow As Integer
    Dim GraphTitlePointStartCol As Integer
    Dim GraphTitlePointEndRow As Integer
    Dim GraphTitlePointEndCol As Integer
 
    Dim GraphDataPointStartRow As Integer
    Dim GraphDataPointStartCol As Integer
    Dim GraphDataPointEndRow As Integer
    Dim GraphDataPointEndCol As Integer
 
    Dim GraphLegPointStartRow As Integer
    Dim GraphLegPointStartCol As Integer
    Dim GraphLegPointEndRow As Integer
    Dim GraphLegPointEndCol As Integer
 
 
    With GT_TABLE
        For i = 0 To ATTR_SIZE - 1
            .Activate
            Dim GridTmp
            GridTmp = Grids(i)
            For j = 0 To UBound(Grids(i), 1) - 1
                For k = 0 To UBound(Grids(i), 2) - 1
                    r = DrawPointRow + j
                    c = DrawPointCol + k
                    .Cells(r, c).Value = GridTmp(j, k)
                    If j = ATTR_GRID_PER_R Then
                        .Cells(r, c).Style = "Percent"
                        .Cells(r, c).NumberFormatLocal = "0.00%"
                    End If
                    If j = ATTR_GRID_TITLE_R And k <> ATTR_GRID_TITLE_C Then
                        .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_R
                    End If
                    If k = ATTR_GRID_TITLE_C And j <> ATTR_GRID_TITLE_R Then
                        .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_C
                    End If
                    If j = ATTR_GRID_TITLE_R And k = ATTR_GRID_TITLE_C Then
                        GraphLegPointStartRow = r
                        GraphLegPointStartCol = c
                    End If
                    If j = ATTR_GRID_SUM_R And k = ATTR_GRID_TITLE_C Then
                        GraphLegPointEndRow = r
                        GraphLegPointEndCol = c
                    End If
 
                    If j = ATTR_GRID_TITLE_R And k = ATTR_GRID_DATA_START_C Then
                        GraphTitlePointStartRow = r
                        GraphTitlePointStartCol = c
                        GraphTitlePointEndRow = r
                    End If
 
                    If j = ATTR_GRID_SUM_R And k = ATTR_GRID_DATA_START_C Then
                        GraphDataPointStartRow = r
                        GraphDataPointStartCol = c
                        GraphDataPointEndRow = r
                    End If
 
                    GraphTitlePointEndCol = c
                    GraphDataPointEndCol = c
 
                    WriteBorder .Cells(r, c), .Cells(r, c)
                Next
                DrawPointCol = DRAW_POINT_COL_START
            Next
            DrawPerGraphPiPer _
                GridTmp(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C), _
                Range(.Cells(GraphTitlePointStartRow, GraphTitlePointStartCol), _
                        .Cells(GraphTitlePointEndRow, GraphTitlePointEndCol)), _
                Range(.Cells(GraphDataPointStartRow, GraphDataPointStartCol), _
                        .Cells(GraphDataPointEndRow, GraphDataPointEndCol)), _
                i * (GRAPH_HEIGHT + CELL_HEIGHT), _
                CELL_WIDTH
 
             DrawPerGraphLinePer _
                GridTmp(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C) & "_line", _
                Range(.Cells(GraphLegPointStartRow, GraphLegPointStartCol), _
                        .Cells(GraphDataPointEndRow, GraphLegPointEndCol)), _
                Range(.Cells(GraphLegPointStartRow, GraphDataPointStartCol), _
                        .Cells(GraphDataPointEndRow, GraphDataPointEndCol)), _
                i * (GRAPH_HEIGHT + CELL_HEIGHT), _
                CELL_WIDTH * K_
 
            DrawPointRow = r + 2
        Next
    End With
    DrawTableAttr = DrawPointRow
End Function
 
Public Function DrawPerGraphLinePer(Title, Range1, Range2, top, left)
    GraphRowPoint = top
    GT_GRAPH.ChartObjects.Add(left, top, GRAPH_WIDTH, GRAPH_HEIGHT).Name = Title
    Dim Ch
    Set Ch = GT_GRAPH.ChartObjects(Title).Chart
    With Ch
        .ChartType = xlColumnClustered
        .SetSourceData Source:=Union(Range1, Range2), PlotBy _
             :=xlRows
    End With
    With Ch
        .HasTitle = True
        .ChartTitle.Characters.Text = Title
        .Axes(xlCategory, xlPrimary).HasTitle = False
        .Axes(xlValue, xlPrimary).HasTitle = False
    End With
    With Ch.Axes(xlCategory)
        .HasMajorGridlines = True
        .HasMinorGridlines = False
    End With
    With Ch.Axes(xlValue)
        .HasMajorGridlines = True
        .HasMinorGridlines = False
        .MinorUnit = 1
        .MajorUnit = 1
    End With
    With Ch
        .HasLegend = False
        .ApplyDataLabels Type:=xlDataLabelsShowNone, LegendKey:=False
        .HasDataTable = True
        .DataTable.ShowLegendKey = False
    End With
    With Ch.PlotArea.Border
        .Weight = xlThin
        .LineStyle = xlNone
    End With
    Ch.PlotArea.Interior.ColorIndex = xlNone
    With Ch.ChartGroups(1)
        .Overlap = 0
        .GapWidth = 150
        .HasSeriesLines = False
        .VaryByCategories = True
    End With
End Function
 
 
Public Function DrawPerGraphPiPer(Title, Range1, Range2, top, left)
    GraphRowPoint = top
    GT_GRAPH.ChartObjects.Add(left, top, GRAPH_WIDTH, GRAPH_HEIGHT).Name = Title
    Dim Ch
    Set Ch = GT_GRAPH.ChartObjects(Title).Chart
    With Ch
        .ChartType = xlPie
        .SetSourceData Source:=Union(Range1, Range2), PlotBy _
             :=xlRows
    End With
    With Ch
        .HasTitle = True
        .ChartTitle.Characters.Text = Title
        .ApplyDataLabels Type:=xlDataLabelsShowPercent, LegendKey _
             :=False, HasLeaderLines:=False
    End With
    With Ch.PlotArea.Border
        .Weight = xlThin
        .LineStyle = xlNone
    End With
    Ch.PlotArea.Interior.ColorIndex = xlNone
    'Ch.Legend.Select
End Function
 
 
Public Function ReadAttributes(RdTargetCol, TmpTargetCol)
    i = GetRowSize(TMP, TmpTargetCol) - 1
    deb i
End Function
 
 
 
 
Public Function MakeGtGrid(Title, Dic, RdCol)
    Dim Grid()
    ReDim Grid(ATTR_GRID_SIZE_R, GetDicSize(Dic) + 2)
 
    Grid(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C) = Title
    Grid(ATTR_GRID_TITLE_R, ATTR_GRID_SUM_C) = GRID_SUM_TITLE_C
    Grid(ATTR_GRID_SUM_R, ATTR_GRID_TITLE_C) = GRID_SUM_TITLE_R
    Grid(ATTR_GRID_PER_R, ATTR_GRID_TITLE_C) = GRID_PER_TITLE_R
    Grid(ATTR_GRID_PER_R, ATTR_GRID_SUM_C) = 1 '100%
 
    Dim count As Integer
    Dim Total As Integer
    Total = 0
    j = 0
    For Each Item1 In Dic.keys
        RD.Activate
        RD.Range(RD.Cells(RD_DATA_START_ROW, RdCol), _
            RD.Cells(GetRowSize(RD, RdCol), RdCol)).Select
        count = Application.WorksheetFunction.CountIf(Selection, Item1)
        Total = count + Total
        k = ATTR_GRID_DATA_START_C + j
        Grid(ATTR_GRID_TITLE_R, k) = Dic(Item1)
        Grid(ATTR_GRID_SUM_R, k) = count
        j = j + 1
    Next
 
    Grid(ATTR_GRID_SUM_R, ATTR_GRID_SUM_C) = Total
 
    j = 0
    For Each Item1 In Dic.keys
        k = ATTR_GRID_DATA_START_C + j
        Grid(ATTR_GRID_PER_R, k) = Grid(ATTR_GRID_SUM_R, k) / Total
        j = j + 1
    Next
    MakeGtGrid = Grid
End Function
 
Public Function MakeGtBook()
    Workbooks.Add
    GT_BOOK_NAME = ActiveWorkbook.Name
    Set GT_BOOK = Workbooks(GT_BOOK_NAME)
End Function
 
Public Function MakeGtDataQ(RowPoint)
    Dim Grids()
    ReDim Grids(2)
    Dim GridsP()
    ReDim GridsP(2)
    Dim Grid
    Grid = MakeGtDataGrid("Q1")
    Grids(0) = Grid
    GridsP(0) = TableTypeN
    Grid = MakeGtDataGridP(Grid)
    Grids(1) = Grid
    GridsP(1) = TableTypeP
 
    DrawTableQ Grids, RowPoint, GridsP
End Function
 
Public Function MakeGtDataGridP(Grid)
    For i = ATTR_GRID_DATA_START_R To UBound(Grid, 1) - 1
        For j = ATTR_GRID_DATA_START_C To UBound(Grid, 2)
            a = Grid(i, j)
            b = Grid(i, ATTR_GRID_SUM_C)
            Grid(i, j) = a / b
        Next
    Next
    For i = ATTR_GRID_DATA_START_R To UBound(Grid, 1) - 1
        Grid(i, ATTR_GRID_SUM_C) = 1
    Next
    MakeGtDataGridP = Grid
End Function
 
Public Function DrawTableQ(Grids, DrawPointRow, GridsP)
    Dim DrawPointCol As Integer
    DrawPointCol = DRAW_POINT_COL_START
 
    Dim GraphTitlePointStartRow As Integer
    Dim GraphTitlePointStartCol As Integer
    Dim GraphTitlePointEndRow As Integer
    Dim GraphTitlePointEndCol As Integer
 
    Dim GraphDataPointStartRow As Integer
    Dim GraphDataPointStartCol As Integer
    Dim GraphDataPointEndRow As Integer
    Dim GraphDataPointEndCol As Integer
 
    With GT_TABLE
        For i = 0 To UBound(Grids, 1) - 1
            .Activate
            Dim GridTmp
            GridTmp = Grids(i)
            For j = 0 To UBound(Grids(i), 1) - 1
                For k = 0 To UBound(Grids(i), 2)
                    r = DrawPointRow + j
                    c = DrawPointCol + k
                    .Cells(r, c).Value = GridTmp(j, k)
                    WriteBorder .Cells(r, c), .Cells(r, c)
                    If j = ATTR_GRID_TITLE_R And k = ATTR_GRID_TITLE_C Then
                        GraphTitlePointStartRow = r
                        GraphTitlePointStartCol = c
                        GraphTitlePointEndCol = c
                    End If
                    If j = ATTR_GRID_TITLE_R And k = ATTR_GRID_DATA_START_C Then
                        GraphDataPointStartRow = r
                        GraphDataPointStartCol = c
                    End If
                    If GridsP(i) = TableTypeP And ATTR_GRID_TITLE_R <> j And ATTR_GRID_TITLE_C <> k Then
                        .Cells(r, c).Style = "Percent"
                        .Cells(r, c).NumberFormatLocal = "0.00%"
                    End If
                    If ATTR_GRID_TITLE_R = j And ATTR_GRID_TITLE_C <> k Then
                         .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_R
                    End If
                    If ATTR_GRID_TITLE_R <> j And ATTR_GRID_TITLE_C = k Then
                         .Cells(r, c).Interior.ColorIndex = GT_TITLE_COLOR_C
                    End If
                Next
                DrawPointCol = DRAW_POINT_COL_START
                GraphTitlePointEndRow = r
                GraphDataPointEndRow = r
                GraphDataPointEndCol = c
            Next
            If GridsP(i) = TableTypeP Then
                DrawPerGraphLinePerQ _
                    GridTmp(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C) & "_L", _
                    Range(.Cells(GraphTitlePointStartRow, GraphTitlePointStartCol), _
                            .Cells(GraphTitlePointEndRow, GraphTitlePointEndCol)), _
                    Range(.Cells(GraphDataPointStartRow, GraphDataPointStartCol), _
                            .Cells(GraphDataPointEndRow, GraphDataPointEndCol)), _
                    i * (GRAPH_HEIGHT + CELL_HEIGHT) + GraphRowPoint, _
                    CELL_WIDTH * K_
            Else
                DrawPerGraphLineQ _
                    GridTmp(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C) & "_C", _
                    Range(.Cells(GraphTitlePointStartRow, GraphTitlePointStartCol), _
                            .Cells(GraphTitlePointEndRow, GraphTitlePointEndCol)), _
                    Range(.Cells(GraphDataPointStartRow, GraphDataPointStartCol), _
                            .Cells(GraphDataPointEndRow, GraphDataPointEndCol)), _
                    (i + 1) * (GRAPH_HEIGHT + CELL_HEIGHT) + GraphRowPoint, _
                    CELL_WIDTH
            End If
            DrawPointRow = r + 2
        Next
    End With
End Function
 
Public Function DrawPerGraphLineQ(Title, Range1, Range2, top, left)
    GT_GRAPH.ChartObjects.Add(left, top, GRAPH_WIDTH, GRAPH_HEIGHT).Name = Title
    Dim Ch
    Set Ch = GT_GRAPH.ChartObjects(Title).Chart
    With Ch
        .ChartType = xlBarClustered
        .SetSourceData Source:=Union(Range1, Range2), PlotBy _
             :=xlColumns
    End With
    With Ch
        .HasTitle = True
        .ChartTitle.Characters.Text = Title
        .Axes(xlCategory, xlPrimary).HasTitle = False
        .Axes(xlValue, xlPrimary).HasTitle = False
    End With
    With Ch.Axes(xlCategory)
        .HasMajorGridlines = True
        .HasMinorGridlines = True
        .Crosses = xlMaximum
        .AxisBetweenCategories = True
        .ReversePlotOrder = True
    End With
    With Ch.Axes(xlValue)
        .HasMajorGridlines = True
        .HasMinorGridlines = False
    End With
    With Ch.PlotArea.Border
        .Weight = xlThin
        .LineStyle = xlNone
    End With
    Ch.PlotArea.Interior.ColorIndex = xlNone
    With Ch
        .HasLegend = True
        .ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False
    End With
End Function
 
 
 
Public Function DrawPerGraphLinePerQ(Title, Range1, Range2, top, left)
    GT_GRAPH.ChartObjects.Add(left, top, GRAPH_WIDTH, GRAPH_HEIGHT).Name = Title
    Dim Ch
    Set Ch = GT_GRAPH.ChartObjects(Title).Chart
    With Ch
        .ChartType = xlBarStacked100
        .SetSourceData Source:=Union(Range1, Range2), PlotBy _
             :=xlColumns
    End With
    With Ch
        .HasTitle = True
        .ChartTitle.Characters.Text = Title
        .Axes(xlCategory, xlPrimary).HasTitle = False
        .Axes(xlValue, xlPrimary).HasTitle = False
    End With
    With Ch.Axes(xlCategory)
        .HasMajorGridlines = True
        .HasMinorGridlines = True
        .Crosses = xlMaximum
        .AxisBetweenCategories = True
        .ReversePlotOrder = True
    End With
    With Ch.Axes(xlValue)
        .HasMajorGridlines = True
        .HasMinorGridlines = False
    End With
    With Ch.PlotArea.Border
        .Weight = xlThin
        .LineStyle = xlNone
    End With
    Ch.PlotArea.Interior.ColorIndex = xlNone
    With Ch
        .HasLegend = True
        .ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False
    End With
End Function
 
 
Public Function MakeGtDataGrid(Qnum)
    i = RD_START_Q
    k = 0
    Dim Lines
    Set Lines = CreateObject("Scripting.Dictionary")
    Do Until RD.Cells(RD_TITLE_ROW, i) = ""
        LY.Activate
        LY.Range(LY.Cells(1, LY_Q_NUM_COL), _
            LY.Cells(GetRowSize(LY, LY_Q_NUM_COL), LY_Q_NUM_COL)).Select
        aa = RD.Cells(RD_TITLE_ROW, i)
        j = Application.WorksheetFunction.CountIf(Selection, aa)
        If j > 0 Then
            Split1 = Split(aa, "_")
            If Split1(0) = Qnum Then
                '正しい選択し
                Set Dic1 = CreateObject("Scripting.Dictionary")
                L = 1
                ee = ""
                Do Until LY.Cells(L, LY_Q_NUM_COL) = ""
                    bb = LY.Cells(L, LY_Q_NUM_COL)
                    If bb = aa Then
                        cc = LY.Cells(L, LY_Q_VALUE)
                        dd = LY.Cells(L, LY_Q_NAME)
                        If Dic1.Exists(cc) = False Then
                            Dic1.Add cc, dd
                            ee = LY.Cells(L, LY_Q_TITLE_COL)
                        End If
                    End If
                    L = L + 1
                Loop
               Lines.Add aa, MakeGtLine(Dic1, i, aa, ee)
                k = k + 1
            End If
        End If
        i = i + 1
    Loop
    Dim Grid()
    n = k + 2
    ReDim Grid(1 + GetDicSize(Lines), n + 1)
    i = 0
    For Each Item1 In Lines.keys
        Dim lgrid
        lgrid = Lines(Item1)
     '   For j = 0 To n + 1
        For j = 0 To UBound(lgrid, 1) - 1
            Grid(ATTR_GRID_DATA_START_R + i, j) = lgrid(j)
        Next
        i = i + 1
    Next
    Grid(ATTR_GRID_TITLE_R, ATTR_GRID_SUM_C) = GRID_SUM_TITLE_C
    Grid(ATTR_GRID_TITLE_R, ATTR_GRID_TITLE_C) = Qnum
    i = 0
    For Each Item1 In Dic1.Items
        Grid(ATTR_GRID_TITLE_R, ATTR_GRID_DATA_START_C + i) = Item1
        i = i + 1
    Next
    MakeGtDataGrid = Grid
End Function
 
Public Function MakeGtLine(Dic, Q_col, Q_key, Q_name)
    Dim ColsCount
    ColsCount = GetDicSize(Dic)
    Dim LineGrid()
    ReDim LineGrid(ColsCount + 2)
    LineGrid(ATTR_GRID_TITLE_C) = Q_name
    Dim NowCol
    NowCol = 0
    RD.Activate
    RD.Range(RD.Cells(RD_DATA_START_ROW, Q_col), _
        RD.Cells(GetRowSize(RD, Q_col), Q_col)).Select
    Dim count
    count = 0
    For Each Item1 In Dic.keys
        LineGrid(NowCol + ATTR_GRID_DATA_START_C) = Application.WorksheetFunction.CountIf(Selection, Item1)
        count = count + LineGrid(NowCol + ATTR_GRID_DATA_START_C)
        NowCol = NowCol + 1
    Next
    LineGrid(ATTR_GRID_SUM_C) = count
    MakeGtLine = LineGrid
End Function
 
 
 
Public Function ReadQ(TargetSheet, TargetCol, StartRow)
    j = TargetCol
    i = StartRow
    Set Dic1 = CreateObject("Scripting.Dictionary")
     Do Until TargetSheet.Cells(j, i) = ""
        aa = TargetSheet.Cells(j, i)
        Split1 = Split(aa, "_")
        If Dic1.Exists(Split1(0)) = False Then
            Dic1.Add Split1(0), Split1(0)
        End If
        i = i + 1
    Loop
    Set ReadQ = Dic1
End Function
 
Public Function GetPat(q_type)
    If q_type = Q_TYPE_CHECK Or q_type = Q_TYPE_MATRIX_CHECK Then
        GetPat = GT_TYPE_M
    Else
        GetPat = GT_TYPE_S
    End If
End Function
Public Function MakeRdData() As Boolean
    MakeRdData = False
    MakeTmpSheet
    MakeSelect SEX_C, A_
    MakeSelect AGE_C, B_
    MakeSelect AGEID_C, C_
    MakeSelect PREFECTURE_C, D_
    MakeSelect AREA_C, E_
    MakeSelect JOB_C, F_
    MakeSelect CELL_C, G_
    MakeSelectQ Question_C
    MakeRdData = True
    BackMain
End Function
 
Public Function MakeTmpSheet()
    RefSheet (TMP_SHEET_NAME)
    Set TMP = P1_BOOK.Worksheets(TMP_SHEET_NAME)
End Function
 
 
Public Function MakeSelect(Col, W_Col)
    i = RD_TITLE_ROW
 
    Set Dic1 = CreateObject("Scripting.Dictionary")
 
    Do Until RD.Cells(i, Col) = ""
        aa = RD.Cells(i, Col)
        If Dic1.Exists(aa) = False Then
            Dic1.Add aa, aa
        End If
        i = i + 1
    Loop
    WriteRow TMP, Dic1, W_Col, True
End Function
 
Public Function MakeSelectQ(W_Col)
    i = RD_START_Q
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Dic1.Add "QESTION", "QESTION"
    Do Until RD.Cells(RD_TITLE_ROW, i) = ""
        aa = RD.Cells(RD_TITLE_ROW, i)
        Split1 = Split(aa, "_")
        If Dic1.Exists(Split1(0)) = False Then
            Dic1.Add Split1(0), Split1(0)
        End If
        i = i + 1
    Loop
    WriteRow TMP, Dic1, W_Col, False
End Function
Option Explicit
 
'ブック
Public Const P1_BOOK_NAME = "P1.xls"
Public P1_BOOK As Workbook
 
Public GT_BOOK_NAME As String
Public GT_BOOK As Workbook
 
Public CR_BOOK_NAME As String
Public CR_BOOK As Workbook
 
'ローデータ
Public Const RD_SHEET_NAME = "RD"
Public Const RD_NAME = "ローデータ"
Public RD As Worksheet
 
Public Const RD_BACK_SHEET_NAME = "RD_BACK"
Public Const RD_BACK_NAME = "ローデータバックアップ"
Public RD_BACK As Worksheet
 
 
'一時データ保存
Public Const TMP_SHEET_NAME = "TMP"
Public TMP As Worksheet
Public Const TMP_BACK_SHEET_NAME = "TMP_BACK"
Public TMP_BACK As Worksheet
 
'開始ページ
Public Const START_SHEET_NAME = "main"
Public START As Worksheet
 
 
'作業用
Public Const FREE_SHEET_NAME = "free"
Public FREE As Worksheet
 
'レイアウト
Public Const LY_SHEET_NAME = "LY"
Public LY As Worksheet
Public Const LY_BACK_SHEET_NAME = "LY_BACK"
Public LY_BACK As Worksheet
 
 
'GT
 
Public Const GT_TABLE_SHEET = "GT表"
Public GT_TABLE As Worksheet
 
Public Const GT_GRAPH_SHEET = "GTグラフ"
Public GT_GRAPH As Worksheet
 
 
'CROSS
 
Public Const CR_TABLE_SHEET = "クロス表"
Public CR_TABLE As Worksheet
 
Public Const CRP_TABLE_SHEET = "クロス％表"
Public CRP_TABLE As Worksheet