<
Function func学部一覧配列作成()
'Public PUB_ary学部等一覧() As type専攻
Set sheet学部 = ThisWorkbook.Sheets("学部学科専攻new")
Dim hajR, owaR
Dim ary学部番号()
Dim ary学部CODE()
Dim ary学部名()
Dim ary学科番号()
Dim ary学科CODE()
Dim ary学科名()
Dim ary専攻番号()
Dim ary専攻CODE()
Dim ary専攻名()
Dim ary質問CODE()
c学部番号 = 2
c学部CODE = 3
c学部名 = 4
c学科番号 = 5
c学科CODE = 6
c学科名 = 7
c専攻番号 = 8
c専攻CODE = 9
c専攻名 = 10
c質問CODE = 11
'表の最後の行
hajR = 6
r = hajR
With sheet学部
While CStr(.Cells(r + 1, c学部番号)) & _
CStr(.Cells(r + 1, c学部CODE)) & _
CStr(.Cells(r + 1, c学部名)) & _
CStr(.Cells(r + 1, c学科番号)) & _
CStr(.Cells(r + 1, c学科CODE)) & _
CStr(.Cells(r + 1, c学科名)) & _
CStr(.Cells(r + 1, c専攻番号)) & _
CStr(.Cells(r + 1, c専攻CODE)) & _
CStr(.Cells(r + 1, c専攻名)) & _
CStr(.Cells(r + 1, c質問CODE)) > ""
r = r + 1
Wend
owaR = r
'番号の最大値
max学部番号 = -1
max学科番号 = -1
max専攻番号 = -1
For r = hajR To owaR
i = r - hajR
'--------------------
dmy = .Cells(r, c学部番号)
If dmy = "" Then
dmy = -1
End If
If max学部番号 < dmy Then
max学部番号 = dmy
End If
'--------------------
dmy = .Cells(r, c学科番号)
If dmy = "" Then
dmy = -1
End If
If max学科番号 < dmy Then
max学科番号 = dmy
End If
'--------------------
dmy = .Cells(r, c専攻番号)
If dmy = "" Then
dmy = -1
End If
If max専攻番号 < dmy Then
max専攻番号 = dmy
End If
'--------------------
ReDim Preserve ary学部番号(i)
ReDim Preserve ary学部CODE(i)
ReDim Preserve ary学部名(i)
ReDim Preserve ary学科番号(i)
ReDim Preserve ary学科CODE(i)
ReDim Preserve ary学科名(i)
ReDim Preserve ary専攻番号(i)
ReDim Preserve ary専攻CODE(i)
ReDim Preserve ary専攻名(i)
ReDim Preserve ary質問CODE(i)
ary学部番号(i) = .Cells(r, c学部番号)
ary学部CODE(i) = .Cells(r, c学部CODE)
ary学部名(i) = .Cells(r, c学部名)
ary学科番号(i) = .Cells(r, c学科番号)
ary学科CODE(i) = .Cells(r, c学科CODE)
ary学科名(i) = .Cells(r, c学科名)
ary専攻番号(i) = .Cells(r, c専攻番号)
ary専攻CODE(i) = .Cells(r, c専攻CODE)
ary専攻名(i) = .Cells(r, c専攻名)
ary質問CODE(i) = .Cells(r, c質問CODE)
Next r
MsgBox CStr(max学部番号) & "/" & CStr(max学科番号) & "/" & CStr(max専攻番号)
ReDim Preserve PUB_ary学部等一覧(max学部番号, max学科番号, max専攻番号)
For r = hajR To owaR
i = r - hajR
If i = 0 Then
If ary学部番号(i) = "" Or ary学部CODE(i) = "" Or ary学部名(i) = "" Then
MsgBox "学部情報不正"
Exit Function
End If
End If
If ary学部番号(i) = "" Then
ary学部番号(i) = ary学部番号(i - 1)
End If
If ary学部CODE(i) = "" Then
ary学部CODE(i) = ary学部CODE(i - 1)
End If
If ary学部名(i) = "" Then
ary学部名(i) = ary学部名(i - 1)
End If
If ary学科番号(i) = "" And (ary学部番号(i) = ary学部番号(i - 1)) Then
ary学科番号(i) = ary学科番号(i - 1)
End If
If ary学科CODE(i) = "" And (ary学部番号(i) = ary学部番号(i - 1)) Then
ary学科CODE(i) = ary学科CODE(i - 1)
End If
If ary学科名(i) = "" And (ary学部番号(i) = ary学部番号(i - 1)) Then
ary学科名(i) = ary学科名(i - 1)
End If
Debug.Print i, ary学部番号(i), ary学部CODE(i), ary学部名(i)
Debug.Print i, ary学科番号(i), ary学科CODE(i), ary学科名(i)
Debug.Print i, ary専攻番号(i), ary専攻CODE(i), ary専攻名(i), ary質問CODE(i)
Debug.Print "---------------------"
Next r
End With
r開始 = sheet学部.Range("学部番号").Row + 1
r = r開始: chk = "A"
While chk <> ""
chk = sheet学部.Cells(r, c学部CODE) & sheet学部.Cells(r, c学科CODE) & sheet学部.Cells(r, c専攻CODE)
r = r + 1
Wend
r終了 = r - 2
If MODE = 1 Then
GoSub 学部表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
If MODE = 2 Then
GoSub 学科表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
If MODE = 3 Then
GoSub 専攻表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
Exit Function
'==================================================
学部表:
'==================================================
my学部CODE = ""
i = 0
For r = r開始 To r終了
If sheet学部.Cells(r, c学部CODE) <> my学部CODE Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c学部番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c学部CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c学部名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
my学部CODE = PUB_aryコンボ(i).CODE
i = i + 1
End If
Next r
Return
'==================================================
学科表:
'==================================================
my学科CODE = ""
i = 0
For r = r開始 To r終了
If sheet学部.Cells(r, c学部CODE) = from学部CODE Then '指定学部コードなら作業
If sheet学部.Cells(r, c学科CODE) <> my学科CODE Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c学科番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c学科CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c学科名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
my学科CODE = PUB_aryコンボ(i).CODE
i = i + 1
End If
End If
Next r
Return
'==================================================
専攻表:
'==================================================
i = 0
For r = r開始 To r終了
If (sheet学部.Cells(r, c学部CODE) = from学部CODE) And _
(Str(sheet学部.Cells(r, c学科CODE)) = Str(from学科CODE)) Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c専攻番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c専攻CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c専攻名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
i = i + 1
End If
Next r
Return
End Function
--------------------------------------------------------
Public Type type学部
学部番号 As Variant
学部CODE As Variant
学部名 As Variant
質問CODE As Variant
End Type
Public Type type学科
学部番号 As Variant
学部CODE As Variant
学部名 As Variant
学科番号 As Variant
学科CODE As Variant
学科名 As Variant
質問CODE As Variant
End Type
Public Type type専攻
学部番号 As Variant
学部CODE As Variant
学部名 As Variant
学科番号 As Variant
学科CODE As Variant
学科名 As Variant
専攻番号 As Variant
専攻CODE As Variant
専攻名 As Variant
質問CODE As Variant
End Type
Public Type typeコンボ
番号 As Variant
CODE As Variant
名称 As Variant
質問 As Variant
End Type
Public Pub_ary学部() As type学部
Public PUB_ary学科() As type学科
Public PUB_ary専攻() As type専攻
Public PUB_aryコンボ() As typeコンボ
'-----------------------------------------------------------------
Function func学部学科専門一覧(MODE, from学部CODE, from学科CODE) As Boolean
from学部CODE = Trim(from学部CODE)
from学科CODE = Trim(from学科CODE)
Set sheet学部 = ThisWorkbook.Sheets("学部学科専攻new")
'MODE 1=学部一覧, 2=学科 ,3=専攻
学部学科専門一覧 = False
If MODE < 1 Or MODE > 3 Then
func学部学科専門一覧 = False
MsgBox "!"
Exit Function
End If
c学部番号 = sheet学部.Range("学部番号").Column
c学部CODE = sheet学部.Range("学部CODE").Column
c学部名 = sheet学部.Range("学部名").Column
c学科番号 = sheet学部.Range("学科番号").Column
c学科CODE = sheet学部.Range("学科CODE").Column
c学科名 = sheet学部.Range("学科名").Column
c専攻番号 = sheet学部.Range("専攻番号").Column
c専攻CODE = sheet学部.Range("専攻CODE").Column
c専攻名 = sheet学部.Range("専攻名").Column
c質問CODE = sheet学部.Range("質問CODE").Column
sheet学部.Activate
r開始 = sheet学部.Range("学部番号").Row + 1
r = r開始: chk = "A"
While chk <> ""
chk = sheet学部.Cells(r, c学部CODE) & sheet学部.Cells(r, c学科CODE) & sheet学部.Cells(r, c専攻CODE)
r = r + 1
Wend
r終了 = r - 2
If MODE = 1 Then
GoSub 学部表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
If MODE = 2 Then
GoSub 学科表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
If MODE = 3 Then
GoSub 専攻表
' aaa = ""
' For i = 0 To UBound(PUB_aryコンボ)
' aaa = aaa & Str(i) & " " & PUB_aryコンボ(i).番号 & " " & PUB_aryコンボ(i).CODE & " " & PUB_aryコンボ(i).名称 & vbCrLf
' Next i
' MsgBox aaa
End If
func学部学科専門一覧 = True
Exit Function
'==================================================
学部表:
'==================================================
my学部CODE = ""
i = 0
For r = r開始 To r終了
If sheet学部.Cells(r, c学部CODE) <> my学部CODE Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c学部番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c学部CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c学部名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
my学部CODE = PUB_aryコンボ(i).CODE
i = i + 1
End If
Next r
Return
'==================================================
学科表:
'==================================================
my学科CODE = ""
i = 0
For r = r開始 To r終了
If sheet学部.Cells(r, c学部CODE) = from学部CODE Then '指定学部コードなら作業
If sheet学部.Cells(r, c学科CODE) <> my学科CODE Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c学科番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c学科CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c学科名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
my学科CODE = PUB_aryコンボ(i).CODE
i = i + 1
End If
End If
Next r
Return
'==================================================
専攻表:
'==================================================
i = 0
For r = r開始 To r終了
If (sheet学部.Cells(r, c学部CODE) = from学部CODE) And _
(Str(sheet学部.Cells(r, c学科CODE)) = Str(from学科CODE)) Then
ReDim Preserve PUB_aryコンボ(i)
PUB_aryコンボ(i).番号 = sheet学部.Cells(r, c専攻番号)
PUB_aryコンボ(i).CODE = sheet学部.Cells(r, c専攻CODE)
PUB_aryコンボ(i).名称 = sheet学部.Cells(r, c専攻名)
PUB_aryコンボ(i).質問 = sheet学部.Cells(r, c質問CODE)
i = i + 1
End If
Next r
Return
End Function
*************************************************************************************
'学部コンボボックス設定
Private Sub cmd1_Click()
ComboBox1.Clear
'コンボボックスを3列にする
ComboBox1.ColumnCount = 3
'3列目を選択された値にする(C学部)
ComboBox1.TextColumn = 3
'それぞれの列幅を指定
ComboBox1.ColumnWidths = "0;0;60"
'項目の追加
ComboBox1.AddItem
ComboBox1.List(0, 0) = 0
ComboBox1.List(0, 1) = "ALL"
ComboBox1.List(0, 2) = "全て"
MODE = 1
学部CODE = 0
学科ODE = 0
'学部一覧を作る
ret = func学部学科専門一覧(MODE, 学部CODE, 学科CODE)
If ret = True Then
For i = 0 To UBound(PUB_aryコンボ)
ComboBox1.AddItem
ComboBox1.List(i + 1, 0) = PUB_aryコンボ(i).番号
ComboBox1.List(i + 1, 1) = PUB_aryコンボ(i).CODE
ComboBox1.List(i + 1, 2) = PUB_aryコンボ(i).名称
Next i
End If
ComboBox1.ListIndex = 0
End Sub
Private Sub cmd2_Click()
'つくりゅボタン
chk学部 = Me.CheckBox1
chk学科 = Me.CheckBox2
chk専攻 = Me.CheckBox3
my学部CODE = Range("G21")
my学科CODE = Range("G24")
my専攻CODE = Range("G27")
'-------------
'学部を作る
'-------------
MODE = 1
If my学部CODE = "ALL" Then
学部CODE = ""
Else
学科CODE = my学部CODE '←これで作れるように !
End If
ret = func学部学科専門一覧(MODE, 学部CODE, 学科CODE)
For i = 0 To UBound(PUB_aryコンボ)
ReDim Preserve Pub_ary学部(i)
Pub_ary学部(i).学部番号 = PUB_aryコンボ(i).番号
Pub_ary学部(i).学部CODE = PUB_aryコンボ(i).CODE
Pub_ary学部(i).学部名 = PUB_aryコンボ(i).名称
Pub_ary学部(i).質問CODE = PUB_aryコンボ(i).質問 '--------------------複数の時に
Next i
'学科を作る
i = 0
If my学科CODE <> "ALL" Then
ReDim Preserve PUB_ary学科(i)
ary学科(i) = my学科CODE
Else '全部
MODE = 2
For i = 0 To UBound(ary_学部)
学部CODE = my学部CODE
学科CODE = ""
ret = func学部学科専門一覧(MODE, 学部CODE, 学科CODE)
For i = 0 To UBound(PUB_aryコンボ)
ReDim Preserve Pub_ary学部(i)
Pub_ary学部(i).学部番号 = Pub_ary学部(i).学部番号
Pub_ary学部(i).学部CODE = Pub_ary学部(i).学部CODE
Pub_ary学部(i).学部名 = Pub_ary学部(i).学部名
Pub_ary学部(i).学部番号 = PUB_aryコンボ(i).番号
Pub_ary学部(i).学部CODE = PUB_aryコンボ(i).CODE
Pub_ary学部(i).学部名 = PUB_aryコンボ(i).名称
Pub_ary学部(i).質問CODE = PUB_aryコンボ(i).質問 '--------------------複数の時に
Next i
End If
End If
End Sub
'学部コード変更→学科コードを変更する
Private Sub ComboBox1_Change()
'選んだINDEX
idx = Me.ComboBox1.ListIndex
'選択失敗→終了
If idx = -1 Then
Exit Sub
End If
'選択した学部Combの値を控えておく
Range("F21") = Me.ComboBox1.List(idx, 0)
Range("G21") = Me.ComboBox1.List(idx, 1)
Range("H21") = Me.ComboBox1.List(idx, 2)
'学科Combのクリアと項目の追加
ComboBox2.Clear
'コンボボックスを3列にする
ComboBox2.ColumnCount = 3
'3列目を選択された値にする(AA学科)
ComboBox2.TextColumn = 3
'それぞれの列幅を指定
ComboBox2.ColumnWidths = "0;0;60"
'初期値
ComboBox2.AddItem
ComboBox2.List(0, 0) = 0
ComboBox2.List(0, 1) = "ALL"
ComboBox2.List(0, 2) = "全て"
'選ばれた学部CODE
学部CODE = Me.ComboBox1.List(idx, 1)
'学部CODEがALLなら、学科CODEもALLのみで終わり
If 学部CODE = "ALL" Then '全て
Exit Sub
End If
'学科CODEを調べに行く
学科ODE = 0
MODE = 2
If func学部学科専門一覧(MODE, 学部CODE, 学科CODE) Then '成功
'項目の追加
For i = 0 To UBound(PUB_aryコンボ)
ComboBox2.AddItem
ComboBox2.List(i + 1, 0) = PUB_aryコンボ(i).番号
ComboBox2.List(i + 1, 1) = PUB_aryコンボ(i).CODE
ComboBox2.List(i + 1, 2) = PUB_aryコンボ(i).名称
Next i
End If
ComboBox2.ListIndex = 0
End Sub
'学科コード変更→専攻コードを変更する
Private Sub ComboBox2_Change()
'選んだINDEX
idx = Me.ComboBox2.ListIndex
'選択失敗→終了
If idx = -1 Then
Exit Sub
End If
'選択した学科Combの値を控えておく
Range("F24") = Me.ComboBox2.List(idx, 0)
Range("G24") = Me.ComboBox2.List(idx, 1)
Range("H24") = Me.ComboBox2.List(idx, 2)
'専攻Combのクリアと項目の追加
ComboBox3.Clear
'コンボボックスを3列にする
ComboBox3.ColumnCount = 3
'3列目を選択された値にする(AAコース)
ComboBox3.TextColumn = 3
'それぞれの列幅を指定
ComboBox3.ColumnWidths = "0;0;60"
'初期値
ComboBox3.AddItem
ComboBox3.List(0, 0) = 0
ComboBox3.List(0, 1) = "ALL"
ComboBox3.List(0, 2) = "全て"
'選ばれた学科CODE
学科CODE = Me.ComboBox2.List(idx, 1)
'学科CODEがALLなら、専攻CODEもALLのみで終わり
If 学科CODE = "ALL" Then '全て
Exit Sub
End If
'専攻CODEを調べに行く
MODE = 3
学部CODE = Range("G21")
学科CODE = Me.ComboBox2.List(idx, 1)
If func学部学科専門一覧(MODE, 学部CODE, 学科CODE) Then
For i = 0 To UBound(PUB_aryコンボ)
ComboBox3.AddItem
ComboBox3.List(i + 1, 0) = PUB_aryコンボ(i).番号
ComboBox3.List(i + 1, 1) = PUB_aryコンボ(i).CODE
ComboBox3.List(i + 1, 2) = PUB_aryコンボ(i).名称
Next i
End If
ComboBox3.ListIndex = 0
End Sub
Private Sub ComboBox3_Change()
'選んだINDEX
idx = Me.ComboBox3.ListIndex
'選択失敗→終了
If idx = -1 Then
Exit Sub
End If
'選択した学部Combの値を控えておく
Range("F27") = Me.ComboBox3.List(idx, 0)
Range("G27") = Me.ComboBox3.List(idx, 1)
Range("H27") = Me.ComboBox3.List(idx, 2)
End Sub
*************************************************************************************
'----------------------------------
Private Sub CommandButton1_Click()
'----------------------------------
Dim myRange As Range
Set myRange = Range("L4:O7")
myRange.Copy
Range("L10").PasteSpecial xlPasteAll
========================================================
Private Sub cmd1_Click()
'コンボボックスを2列にする
ComboBox1.ColumnCount = 2
'2列目を選択された値にする
ComboBox1.TextColumn = 2
'それぞれの列幅を指定
ComboBox1.ColumnWidths = "0;60"
'項目の追加
ComboBox1.Clear
ComboBox1.AddItem
ComboBox1.List(0, 0) = "UAA"
ComboBox1.List(0, 1) = "A学部"
ComboBox1.AddItem
ComboBox1.List(1, 0) = "UBB"
ComboBox1.List(1, 1) = "B学部"
ComboBox1.AddItem
ComboBox1.List(2, 0) = "UCC"
ComboBox1.List(2, 1) = "C学部"
ComboBox1.AddItem
' ComboBox1.List(3, 0) = "2009年"
' ComboBox1.List(3, 1) = "1月"
' ComboBox1.AddItem
' ComboBox1.List(4, 0) = "2009年"
' ComboBox1.List(4, 1) = "2月"
End Sub
========================================================
Private Sub cmd2_Click()
MsgBox ComboBox1.Value
End Sub
========================================================
Private Sub ComboBox1_Change()
Dim myRange As Range
Dim aryBU() As type専攻
i = 0
r = 6
While Cells(r, 2) & Cells(r, 3) & Cells(r, 4) & Cells(r, 5) & Cells(r, 6) & Cells(r, 7) <> ""
ReDim Preserve aryBU(i)
aryBU(i).学部番号 = Cells(r, 2)
aryBU(i).学部CODE = Cells(r, 3)
aryBU(i).学部名 = Cells(r, 4)
aryBU(i).学科番号 = Cells(r, 5)
aryBU(i).学科CODE = Cells(r, 6)
aryBU(i).学科名 = Cells(r, 7)
aryBU(i).専攻番号 = Cells(r, 8)
aryBU(i).専攻CODE = Cells(r, 9)
aryBU(i).専攻名 = Cells(r, 10)
r = r + 1
i = i + 1
Wend
aaa = ""
For i = 0 To UBound(aryBU)
aaa = aaa & Str(i) & " " & aryBU(i).学部番号 & " " & aryBU(i).学部CODE & " " & aryBU(i).学部名 & vbCrLf & _
aryBU(i).学科番号 & " " & aryBU(i).学科CODE & " " & aryBU(i).学科名 & vbCrLf & _
aryBU(i).専攻番号 & " " & aryBU(i).専攻CODE & " " & aryBU(i).専攻名 & vbCrLf & "------------" & vbCrLf
Next i
MsgBox aaa
'学部番号の補完
bak学部CODE = "9999"
bak学科CODE = "9999"
'もし学部番号が空白で、学科CODEが上と同じなら、学部コードを＋
'もし学科〃
'もし専攻番号が???
For i = 0 To UBound(aryBU)
If aryBU(i).学部CODE = back学部CODE Then
aaa = aaa & Str(i) & " " & aryBU(i).学部番号 & " " & aryBU(i).学部CODE & " " & aryBU(i).学部名 & vbCrLf & _
aryBU(i).学科番号 & " " & aryBU(i).学科CODE & " " & aryBU(i).学科名 & vbCrLf & _
aryBU(i).専攻番号 & " " & aryBU(i).専攻CODE & " " & aryBU(i).専攻名 & vbCrLf & "------------" & vbCrLf
Next i
MsgBox aaa
End Sub
========================================================
プロパティのStyleを「2-ｆｍStyleDropDownList」に設定すると、クリックしてキーボードからの入力はできなくなります。
ドロップダウンリストにはListFillRange「F2:F8」の内容が表示され、リストから選択するとLinkedCell「A3」に選択された値が表示されました。
リストに項目を追加するには AddItem メソッドを使用する方法と、RowSource プロパティにリスト項目が入力されたワークシートのセル範囲を指定する方法があります。AddItem メソッドで追加したリスト項目は Clear メソッドや RemoveItem メソッドで削除することが可能です。
cbo.AddItem [ Item ] [, Index ]
※上記構文中の cbo はコンボボックスオブジェクトのインスタンスを表します（以下、同様）。
引数名 省略 説明
Item ○ リスト項目に追加する文字列を指定します。 省略すると空白行が追加されます。
Index ○ 新しい項目を挿入する位置を示す整数値を指定します。 位置は先頭項目がゼロとなります。 省略すると末尾に追加されます。
Clear メソッドはリストに追加された項目をすべて削除します。
構文
cbo.Clear ※引数なし
選択項目のインデックス（ListIndex プロパティ）
コンボボックスのリスト内で現在選択されている項目のインデックスは ListIndex プロパティで取得可能です。リスト内の項目が選択されていない場合は -1 が返ってきます。
このプロパティは値を設定することも可能で、ゼロ以上の数値を設定するとそのインデックスに対応した項目がコンボボックス内に表示されます。-1 を設定すると未選択状態（コンボボックス内は空欄）になります。
'コンボボックスにリスト先頭項目を表示
ComboBox1.ListIndex = 0
'選択されている項目のインデックスを表示
MsgBox "ListIndex = " & ComboBox1.ListIndex
リスト表示最大数（ListRows プロパティ）
'ドロップダウンリストとしてのみ使用
ComboBox1.Style = fmStyleDropDownList
DropButtonStyle定数一覧
定数 値 内容
fmStyleDropDownCombo 0 選択項目のリストを持つコンボ ボックスとして機能します。 編集領域に値を入力したり、選択項目のリストから値を選択することができます。
fmStyleDropDownList 2 ドロップダウンリストとして機能します。リストから値を選択しなければなりません。
------------------------
1）ColumnCountでコンボボックスを2列にします。
2）TextColumnで表示する列を指定します。
3）ColumnWidthsで列幅を指定します。
========================================================
-------------------------------------------------------------
Private Sub CommandButton1_Click()
'----------------------------------
ActiveSheet.ChartObjects("グラフ 1").Activate
ActiveChart.ChartArea.Copy
Range("B22").Select
ActiveSheet.Paste
ActiveSheet.Range("B20") = ActiveChart.Parent.Name
myName = ActiveChart.Parent.Name
Range("B25").Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects(myName).Activate
ActiveChart.Parent.Name = "AAA"
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "Time:" & Str(Time())
ActiveChart.PlotArea.Select
ActiveChart.SetSourceData Source:=Range("M23:N29")
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Application.CommandBars("Format Object").Visible = False
With Selection.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
End Sub
-------------------------------------------------------------
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Sheet2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Private Sub cmb学部_Change()
MsgBox "change"
'学科の配列作る
ret = 学科配列作成(Me.cmb学部.Value, PUB_ary専攻, PUB_ary学科)
'配列をシートに張り付ける
'Range("学科").Cells.Clear
rHajime = Range("学科番号").Row
cHajime = Range("学科番号").Column
''張り付ける時、cmbボックスのchangeイベントが発生しないようにする
backup = Me.cmb学科.ListFillRange
Me.cmb学科.ListFillRange = ""
'Range("学科").ClearContents
Cells(rHajime + 1, cHajime) = "0"
Cells(rHajime + 1, cHajime + 1) = "全て"
For r = 0 To UBound(PUB_ary学科)
Cells(rHajime + r + 2, cHajime) = PUB_ary学科(r).学科番号
Cells(rHajime + r + 2, cHajime + 1) = PUB_ary学科(r).学科CODE & "｜" & PUB_ary学科(r).学科名
Next r
Me.cmb学科.ListFillRange = backup
End Sub
Function 学科配列作成(my学部, ByRef PUB_ary専攻() As type専攻, ByRef PUB_ary学科() As type学科)
Dim cntS, cntK
If my学部 = 0 Then '全部
' Range("学科").Cells.Clear
Exit Function
End If
cntS = 0 '専攻配列の添え字
cntK = 0 '学科配列の添え字
ReDim Preserve PUB_ary学科(cntK)
' PUB_ary学科(cntK).学科番号 = PUB_ary専攻(cntS).学科番号
' PUB_ary学科(cntK).学科名 = PUB_ary専攻(cntS).学科CODE & "｜" & PUB_ary専攻(cntS).学科名
For cntS = 0 To UBound(PUB_ary専攻)
If PUB_ary専攻(cntS).学部番号 = my学部 Then
'1つ前の学科と違う時だけ処理
If cntK = 0 Then
PUB_ary学科(cntK).学科番号 = PUB_ary専攻(cntS).学科番号
PUB_ary学科(cntK).学科CODE = PUB_ary専攻(cntS).学科CODE
PUB_ary学科(cntK).学科名 = PUB_ary専攻(cntS).学科名
cntK = cntK + 1
Else
If PUB_ary専攻(cntS).学科番号 <> PUB_ary学科(cntK - 1).学科番号 Then
' cntK = cntK + 1
ReDim Preserve PUB_ary学科(cntK)
PUB_ary学科(cntK).学部番号 = PUB_ary専攻(cntS).学部番号
PUB_ary学科(cntK).学部CODE = PUB_ary専攻(cntS).学部CODE
PUB_ary学科(cntK).学部名 = PUB_ary専攻(cntS).学部名
PUB_ary学科(cntK).学科番号 = PUB_ary専攻(cntS).学科番号
PUB_ary学科(cntK).学科CODE = PUB_ary専攻(cntS).学科CODE
PUB_ary学科(cntK).学科名 = PUB_ary専攻(cntS).学科名
cntK = cntK + 1
End If
End If
End If
Next cntS
'書き出してみる
xx = ""
For i = 0 To UBound(PUB_ary学科)
xx = xx & vbCrLf & PUB_ary学科(i).学科番号 & " " & PUB_ary学科(i).学科CODE & " " & PUB_ary学科(i).学科名 & vbCrLf & "------"
Next i
MsgBox "学科配列" & vbCrLf & xx
End Function
Private Sub cmb学部_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
MsgBox "keydown"
End Sub
Private Sub cmb学部_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
MsgBox "keypress"
End Sub
Private Sub cmd基礎ファイル_Click()
Dim cHajime, rHajime
MsgBox "基礎ファイルを読みます"
'''シート読み込み実験
Dim ary学部学科専攻() As type専攻
'----------基本セットです
'プレーンに読み込む
ret = シート読み込み(PUB_ary専攻)
'不足している部分を追加する
'ret = 整理整頓(ary学部学科専攻, PUB_ary専攻) '学科専攻が空白の場合の値の与え方（分析方法）が曖昧なので、スキップ。全セル埋めること
'---------学部だけの配列を作る
ret = 学部配列(PUB_ary専攻, Pub_ary学部)
'配列をシートに張り付ける
Range("学部").Cells.Clear
rHajime = Range("学部番号").Row
cHajime = Range("学部番号").Column
''張り付ける時、cmbボックスのchangeイベントが発生しないようにする
backup = Me.cmb学部.ListFillRange
Me.cmb学部.ListFillRange = ""
Cells(rHajime + 1, cHajime) = "0"
Cells(rHajime + 1, cHajime + 1) = "全て"
For r = 0 To UBound(Pub_ary学部)
Cells(rHajime + r + 2, cHajime) = Pub_ary学部(r).学部番号
Cells(rHajime + r + 2, cHajime + 1) = Pub_ary学部(r).学部CODE & "｜" & Pub_ary学部(r).学部名
Next r
Me.cmb学部.ListFillRange = backup
'学部に応じて学科配列を作る
'学部学科に応じて専攻配列を作る
End Sub
Function シート読み込み(ByRef aryALL() As type専攻) As Boolean
Dim sheet学部 As Worksheet
Set sheet学部 = ThisWorkbook.Sheets("学部学科専攻")
rmin = 6 'データはここから始まる
cnt = 0 '配列のカウンタ
bef_学部 = -1
bef_学科 = -1
bef_専攻 = -1
r = rmin
'8=H列、専攻CODE
With sheet学部
chk = "": For c = 1 To 8: chk = chk & .Cells(r, c): Next c
While chk <> "" '終了はA～Hが空
ReDim Preserve aryALL(cnt)
aryALL(cnt).学部番号 = .Cells(r, 1)
aryALL(cnt).学部CODE = .Cells(r, 2)
aryALL(cnt).学部名 = .Cells(r, 3)
aryALL(cnt).学科番号 = .Cells(r, 4)
aryALL(cnt).学科CODE = .Cells(r, 5)
aryALL(cnt).学科名 = .Cells(r, 6)
aryALL(cnt).専攻番号 = .Cells(r, 7)
aryALL(cnt).専攻CODE = .Cells(r, 8)
aryALL(cnt).専攻名 = .Cells(r, 9)
r = r + 1
cnt = cnt + 1
chk = "": For c = 1 To 8: chk = chk & .Cells(r, c): Next c
Wend
End With
'書き出してみる
xx = ""
For i = 0 To UBound(aryALL)
xx = xx & vbCrLf & aryALL(i).学部番号 & " " & aryALL(i).学部CODE & " " & aryALL(i).学部名 & _
vbCrLf & aryALL(i).学科番号 & " " & aryALL(i).学科CODE & " " & aryALL(i).学科名 & _
vbCrLf & aryALL(i).専攻番号 & " " & aryALL(i).専攻CODE & " " & aryALL(i).専攻名 & vbCrLf & "------"
Next i
MsgBox "読みました" & vbCrLf & xx
End Function
Function 学部配列(ByRef PUB_ary専攻() As type専攻, Pub_ary学部() As type学部) As Boolean
Dim cntS, cntB
cntS = 0 '専攻配列の添え字
cntB = 0 '学部配列の添え字
ReDim Preserve Pub_ary学部(cntB)
Pub_ary学部(cntB).学部番号 = PUB_ary専攻(cntS).学部番号
Pub_ary学部(cntB).学部CODE = PUB_ary専攻(cntS).学部CODE
Pub_ary学部(cntB).学部名 = PUB_ary専攻(cntS).学部名
For cntS = 1 To UBound(PUB_ary専攻)
'1つ前の学部と違う時だけ処理
If PUB_ary専攻(cntS).学部番号 <> PUB_ary専攻(cntS - 1).学部番号 Then
cntB = cntB + 1
ReDim Preserve Pub_ary学部(cntB)
Pub_ary学部(cntB).学部番号 = PUB_ary専攻(cntS).学部番号
Pub_ary学部(cntB).学部CODE = PUB_ary専攻(cntS).学部CODE
Pub_ary学部(cntB).学部名 = PUB_ary専攻(cntS).学部名
End If
Next cntS
'書き出してみる
xx = ""
For i = 0 To UBound(Pub_ary学部)
xx = xx & vbCrLf & Pub_ary学部(i).学部番号 & " " & Pub_ary学部(i).学部CODE & " " & Pub_ary学部(i).学部名 & vbCrLf & "------"
Next i
MsgBox "学部配列" & vbCrLf & xx
End Function
Function 整理整頓(ByRef ary学部学科専攻() As type専攻, ByRef PUB_ary専攻() As type専攻) As Boolean
'---------------------------------------
MsgBox "整理整頓にきました"
'---------------------------------------
'整理の方針
'ぐるぐる回して、空欄を埋めて→ary専攻へ
bk学部番号 = "@@@@@"
bk学部CODE = "@@@@@"
bk学部名 = "@@@@@"
bk学科番号 = "@@@@@"
bk学科CODE = "@@@@@"
bk学科名 = "@@@@@"
bk専攻番号 = "@@@@@"
bk専攻CODE = "@@@@@"
bk専攻名 = "@@@@@"
ReDim Preserve PUB_ary専攻(UBound(ary学部学科専攻))
For i = 0 To UBound(ary学部学科専攻)
PUB_ary専攻(i) = ary学部学科専攻(i)
'---------------学部
If PUB_ary専攻(i).学部番号 <> bk学部番号 Then '1つ前の学部番号と異なる
If PUB_ary専攻(i).学部番号 <> "" Then 'そして空白ではない
bk学部番号 = PUB_ary専攻(i).学部番号
End If
PUB_ary専攻(i).学部番号 = bk学部番号
End If
If PUB_ary専攻(i).学部CODE <> bk学部CODE Then '1つ前の学部CODEと異なる
If PUB_ary専攻(i).学部CODE <> "" Then 'そして空白ではない
bk学部CODE = PUB_ary専攻(i).学部CODE
End If
PUB_ary専攻(i).学部CODE = bk学部CODE
End If
If PUB_ary専攻(i).学部名 <> bk学部名 Then '1つ前の学部名と異なる
If PUB_ary専攻(i).学部名 <> "" Then 'そして空白ではない
bk学部名 = PUB_ary専攻(i).学部名
End If
PUB_ary専攻(i).学部名 = bk学部名
End If
'---------------学科
If PUB_ary専攻(i).学科番号 <> bk学科番号 Then '1つ前の学科番号と異なる
If PUB_ary専攻(i).学科番号 <> "" Then 'そして空白ではない
bk学科番号 = PUB_ary専攻(i).学科番号
End If
PUB_ary専攻(i).学科番号 = bk学科番号
End If
If PUB_ary専攻(i).学科CODE <> bk学科CODE Then '1つ前の学科CODEと異なる
If PUB_ary専攻(i).学科CODE <> "" Then 'そして空白ではない
bk学科CODE = PUB_ary専攻(i).学科CODE
End If
PUB_ary専攻(i).学科CODE = bk学科CODE
End If
If PUB_ary専攻(i).学科名 <> bk学科名 Then '1つ前の学科名と異なる
If PUB_ary専攻(i).学科名 <> "" Then 'そして空白ではない
bk学科名 = PUB_ary専攻(i).学科名
End If
PUB_ary専攻(i).学科名 = bk学科名
End If
Next i
xx = ""
For i = 0 To UBound(ary学部学科専攻)
xx = xx & vbCrLf & PUB_ary専攻(i).学部番号 & " " & PUB_ary専攻(i).学部CODE & " " & PUB_ary専攻(i).学部名 & _
vbCrLf & PUB_ary専攻(i).学科番号 & " " & PUB_ary専攻(i).学科CODE & " " & PUB_ary専攻(i).学科名 & _
vbCrLf & PUB_ary専攻(i).専攻番号 & " " & PUB_ary専攻(i).専攻CODE & " " & PUB_ary専攻(i).専攻名 & vbCrLf & "------"
Next i
MsgBox "整理整頓したよ！！" & vbCrLf & xx
End Function
-------------------------------------------------------------
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Sheet3"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'==============================================
Private Sub CommandButton1_Click()
''''構造体配列の引数実験
'==============================================
Dim ary学部() As type学部
ReDim ary学部(2)
ary学部(0).学部番号 = "1"
ary学部(0).学部CODE = "UL"
ary学部(0).学部名 = "文学部"
ary学部(1).学部番号 = "2"
ary学部(1).学部CODE = "UE"
ary学部(1).学部名 = "経済学部"
ary学部(2).学部番号 = "3"
ary学部(2).学部CODE = "UB"
ary学部(2).学部名 = "経営学部"
'構造体をfunctionに渡し、値の変更と配列数を変更する
ret = 表示(ary学部)
'値変更,要素変更 OKでした
For i = 0 To UBound(ary学部)
xx = xx & vbCrLf & ary学部(i).学部番号 & " " & ary学部(i).学部CODE & " " & ary学部(i).学部名
Next i
MsgBox "帰宅後表示" & vbCrLf & xx
End Sub
'構造体を引数で渡される
Function 表示(ByRef ary() As type学部)
For i = 0 To UBound(ary)
xx = xx & vbCrLf & ary(i).学部番号 & " " & ary(i).学部CODE & " " & ary(i).学部名
Next i
MsgBox "呼ばれて表示" & vbCrLf & xx
'呼ばれた先で値変更
ary(2).学部CODE = "UB2"
'呼ばれた先で要素数変更
ReDim Preserve ary(3)
ary(3).学部番号 = "4"
ary(3).学部CODE = "UJ"
ary(3).学部名 = "法学部"
End Function
''==============================================
'Private Sub CommandButton2_Click()
''''シート読み込み実験
'
'
''==============================================
'
'
'
'Dim ary学部学科専攻() As type専攻
'
''----------基本セットです
''プレーンに読み込む
'ret = シート読み込み(ary学部学科専攻)
''不足している部分を追加する
'ret = 整理整頓(ary学部学科専攻, PUB_ary学部, PUB_ary学科, PUB_ary専攻)
''学部だけの配列を作る
''-------------------
'
'
'
'
'
''学部に応じて学科配列を作る
'
''学部学科に応じて専攻配列を作る
'
'End Sub
'
'Function 整理整頓(ByRef ary学部学科専攻() As type専攻, _
' ByRef PUB_ary学部() As type学部, _
' ByRef PUB_ary学科() As type学科, _
' ByRef PUB_ary専攻() As type専攻) As Boolean
'
'
' '---------------------------------------
' 'MSG
' xx = ""
' For i = 0 To UBound(ary学部学科専攻)
' xx = xx & vbCrLf & ary学部学科専攻(i).学部番号 & " " & ary学部学科専攻(i).学部CODE & " " & ary学部学科専攻(i).学部名 & _
' vbCrLf & ary学部学科専攻(i).学科番号 & " " & ary学部学科専攻(i).学科CODE & " " & ary学部学科専攻(i).学科名 & _
' vbCrLf & ary学部学科専攻(i).専攻番号 & " " & ary学部学科専攻(i).専攻CODE & " " & ary学部学科専攻(i).専攻名 & vbCrLf & "------"
' Next i
' MsgBox "整理整頓にきました" & vbCrLf & xx
' '---------------------------------------
'
' '整理の方針
' 'ぐるぐる回して、空欄を埋めて→専攻へ
' '専攻をぐるぐる回して、学科へ
' '学科をぐるぐる回して、学部へ
'
'
' bk学部番号 = "@@@@@"
' bk学部CODE = "@@@@@"
' bk学部名 = "@@@@@"
'
' bk学科番号 = "@@@@@"
' bk学科CODE = "@@@@@"
' bk学科名 = "@@@@@"
'
' bk専攻番号 = "@@@@@"
' bk専攻CODE = "@@@@@"
' bk専攻名 = "@@@@@"
'
'
' ReDim Preserve PUB_ary専攻(UBound(ary学部学科専攻))
' xx = ""
' For i = 0 To UBound(ary学部学科専攻)
'
' PUB_ary専攻(i) = ary学部学科専攻(i)
' Call 比較して代入(PUB_ary専攻(i).学部番号, bk学部番号)
'
'
' If PUB_ary専攻(i).学部番号 <> bk学部番号 Then '1つ前の学部番号と異なる
'
' If PUB_ary専攻(i).学部番号 <> "" Then 'そして空白ではない
' bk学部番号 = PUB_ary専攻(i).学部番号
' End If
'
' PUB_ary専攻(i).学部番号 = bk学部番号
' End If
'
'
' xx = xx & vbCrLf & PUB_ary専攻(i).学部番号 & " " & PUB_ary専攻(i).学部CODE & " " & PUB_ary専攻(i).学部名 & _
' vbCrLf & PUB_ary専攻(i).学科番号 & " " & PUB_ary専攻(i).学科CODE & " " & PUB_ary専攻(i).学科名 & _
' vbCrLf & PUB_ary専攻(i).専攻番号 & " " & PUB_ary専攻(i).専攻CODE & " " & PUB_ary専攻(i).専攻名 & vbCrLf & "------"
'
' Next i
'
' MsgBox "整理整頓したよ！！" & vbCrLf & xx
'
'End Function
'
'Function シート読み込み(ByRef aryALL() As type専攻) As Boolean
'
'rmin = 2 'データはここから始まる
'cnt = 0 '配列のカウンタ
'bef_学部 = -1
'bef_学科 = -1
'bef_専攻 = -1
'
'r = rmin
''8=H列、専攻CODE
'chk = "": For c = 1 To 8: chk = chk & Cells(r, c): Next c
'
'
'While chk <> "" '終了はA～Hが空
' ReDim Preserve aryALL(cnt)
' aryALL(cnt).学部番号 = Cells(r, 1)
' aryALL(cnt).学部CODE = Cells(r, 2)
' aryALL(cnt).学部名 = Cells(r, 3)
' aryALL(cnt).学科番号 = Cells(r, 4)
' aryALL(cnt).学科CODE = Cells(r, 5)
' aryALL(cnt).学科名 = Cells(r, 6)
' aryALL(cnt).専攻番号 = Cells(r, 7)
' aryALL(cnt).専攻CODE = Cells(r, 8)
' aryALL(cnt).専攻名 = Cells(r, 9)
' r = r + 1
' cnt = cnt + 1
' chk = "": For c = 1 To 8: chk = chk & Cells(r, c): Next c
'Wend
'
' '書き出してみる
' xx = ""
' For i = 0 To UBound(aryALL)
' xx = xx & vbCrLf & aryALL(i).学部番号 & " " & aryALL(i).学部CODE & " " & aryALL(i).学部名 & _
' vbCrLf & aryALL(i).学科番号 & " " & aryALL(i).学科CODE & " " & aryALL(i).学科名 & _
' vbCrLf & aryALL(i).専攻番号 & " " & aryALL(i).専攻CODE & " " & aryALL(i).専攻名 & vbCrLf & "------"
'
' Next i
'
' MsgBox "読みました" & vbCrLf & xx
'
'
'
'
'
'End Function