以下は、動作保証をしないので、自己責任で確認のこと。プログラム等その他により生じたいかなる損害等その他について、責任を負いませんので、予めご了承してください。
平成27年度基本情報技術者試験：午後試験問13 これについてはIPAのサイトからダウンロードして検討のこと
Option Explicit
Sub GetFileNameInFullPath()
Dim i As Integer
Dim i2 As Integer
Dim sData As String
Dim pPath As String
Dim result As String
pPath = Application.ActiveWorkbook.Path & "\test.csv"
Do
i = InStr(i2 + 1, pPath, "\")
If i = 0 Then
Exit Do
End If
i2 = i
Loop
result = Mid(pPath, i2 + 1)
' Debug.Print result
End Sub
【応用例】InStr関数の使用例なので、各種いろいろな処理に使える。
注：パスの抽出そのものはマイクロソフトの関数組み合わせでも処理が可能。
【資料】
VBAのヘルプファイルのサンプルに類似処理あり。
Option Explicit
Type CEmployee
no As Long
info As Long
End Type
Const MAX_NO As Long = 100
Sub InsertSort(a() As Long)
'挿入ソート
'右方向に小さい値を入れ替えする並び替え
'データがほぼ整列しているときに、非常に速い（末尾にデータを追加する場合などに使用）
Dim i As Long
Dim j As Long
Dim tmp As Long
'配列1からMaxまで繰り返す
For i = LBound(a) + 1 To UBound(a)
'カウント変数を設定
j = i
'現在の配列の値が小さい添え字の配列より小さいときは繰り返す
Do While a(j - 1) > a(j)
DoEvents
'ひとつ前の値を取得・退避
temp = a(j - 1)
'現在の値をひとつ前の値に設定し、次の配列の値との大小比較に備える
a(j - 1) = a(j)
'退避したひとつ前の値を現在の配列に設定
a(j) = temp
'添え字の値を１つ減算する
j = j - 1
'最初の配列に到達したら、処理を抜ける
If j = LBound(a) Then Exit Do
Loop
Next i
End Sub
'クイックソート
Sub QuickSort(a() As Long, ByVal idxStart As Long, ByVal idxEnd As Long)
Dim idxPivot As Long
If idxEnd - idxStart > 0 Then
'配列を分割する
idxPivot = PartitionU(a(), idxStart, idxEnd)
'左側部分をソートする
QuickSort a(), idxStart, idxPivot - 1
'右側部分をソートする
QuickSort a(), idxPivot + 1, idxEnd
End If
End Sub
Function PartitionU(a() As Long, ByVal idxStart As Long, ByVal idxEnd As Long)
Dim pivot As Long
Dim i As Long
Dim j As Long
Dim temp As Long
i = idxStart - 1
j = idxEnd
pivot = a(idxEnd)
Do While True
'a(i) >= pivotとなるiを探す
Do
i = i + 1
Loop While a(i) < pivot
'a(j) <= pivotとなるjを探す
Do
j = j - 1
If j <= i Then Exit Do
Loop While a(j) > pivot
If j <= i Then Exit Do
'a(i)とa(j)を交換する
temp = a(i)
a(i) = a(j)
a(j) = temp
Loop
'a(i)とpivotを交換する
a(idxEnd) = a(i)
a(i) = pivot
PartitionU = i
End Function
Sub BinSort(a() As CEmployee)
'ビンソート
'配列のビンの箱に、ソートするデータを箱の番号に合わせて、配列のデータを割り振り
'箱の順番で、配列のデータを取り出してソートする
'範囲が決まっていて（100件以内）、重複が無い場合 例 社員番号順にソート
Dim Bin(0 To MAX_NO) As CEmployee
Dim i As Long
Dim j As Long
'初期化
For i = LBound(Bin) To UBound(Bin)
Bin(i).no = -1
Next i
'値のある配列のみ、その配列をコピーする
For i = LBound(Bin) To UBound(Bin)
Bin(a(i).no) = a(i)
Next i
'最小の添え字を取得
j = LBound(a)
For i = LBound(Bin) To UBound(Bin)
'-1でないものだけを配列aに書き戻す
If Bin(i).no <> -1 Then
a(j) = Bin(i)
j = j + 1
End If
Next i
End Sub
Private Sub DistCountSort(a() As CEmployee, b() As CEmployee)
'分布数え上げソート
'配列のビンの箱に、ソートするデータを箱の番号に合わせて、配列のデータを割り振り
'箱の順番で、配列のデータを取り出してソートする
'範囲が決まっていて（100件以内）、重複が有る場合 例 社員番号順にソート
Dim Bin(0 To MAX_NO) As Long '枚数用変数
Dim i As Long
'枚数の初期化
For i = LBound(Bin) To UBound(Bin)
Bin(i) = 0
Next i
'Binの値の足し合わせ、値がi以下のカードが何枚あるか（累計度数分布）
For i = LBound(a) To UBound(a)
'初期値0にNoがあれば、1枚加算する（重複ならその数の分、加算する）
Bin(a(i).no) = Bin(a(i).no) + 1
Next i
'値のある配列のみ、その配列をコピーする
For i = LBound(Bin) To UBound(Bin) - 1
'Binの値の足し合わせ
Bin(i + 1) = Bin(i + 1) + Bin(i)
Next i
'01234 (重複枚数)
'0 0 0
'1 1 1+0
'2 3 2+1
'3 6 3+3
'4 10 4+6
'結果の設定 bに結果を設定する
For i = UBound(a) To LBound(a) Step -1
b(Bin(a(i).no) - 1) = a(i)
Bin(a(i).no) = Bin(a(i).no) - 1
Next i
End Sub
■応用例
■資料
Microsoftの教育系のサイトに昔、あったような記憶があります。ソースは古典。
Print # ステートメントなど等その他の組み合わせによる不具合などに注意
Option Explicit
'ファイルには5つのレコードがあること
Type Record
ID As Integer 'ID
Name As String * 20 'テキスト
End Type
Public Function FreeFile関数処理()
Dim RecordNumber As Integer 'カウント変数
Dim FileNumber As Integer '範囲1～ 511の有効なファイル番号
Dim MyRecord As Record 'ユーザー関数用
Dim Position As Variant 'レコード番号指定用
Dim sFile As String 'ファイル
Dim MyNumber As Variant 'ID
Dim MyString As String 'テキスト
Dim MyBool As Boolean
Dim MyDate As Date
Dim MyNull As Variant
Dim MyError As Variant
Dim CommandType As Integer
Dim Mode As String
On Error GoTo err_1
Err.Clear
CommandType = 1
sFile = Application.ThisWorkbook.Path & Chr(92) & "test.csv"
Mode = "シーケンシャルモード【書き込み】"
'Mode = "シーケンシャルモード【読み込み】"
'Mode = "Binary モード"
'Mode = "Random モード"
FileNumber = VBA.FreeFile ' 使用可能なファイル番号の取得
Select Case Mode
Case "シーケンシャルモード【書き込み】"
'共有制御（明示）
'Open sFile For Output Shared As #FileNumber
Open sFile For Output As #FileNumber ' Open file name.
If CommandType = 1 Then
Write #FileNumber, "Hello World", 234 ' テキストの書き込み
Write #FileNumber, ' 「blank line」の書き込み
' Assign----------------------------------------
MyBool = False: MyDate = #2/12/1969#: MyNull = Null
MyError = CVErr(32767)
'-----------------------------------------------
Write #FileNumber, MyBool; " is a Boolean value"
Write #FileNumber, MyDate; " is a date"
Write #FileNumber, MyNull; " is a null value"
Write #FileNumber, MyError; " is an error value"
Write #FileNumber, ' 「blank line」の書き込み
ElseIf CommandType = 2 Then
Print #FileNumber, "This is a test" ' テキストの書き込み
Print #FileNumber, ' 「blank line」の書き込み
'-----------------------------------------------
Print #FileNumber, "Zone 1"; Tab; "Zone 2" ' Print in two print zones.
Print #FileNumber, "Hello"; " "; "World" ' Separate strings with space.
Print #FileNumber, Spc(5); "5 leading spaces " ' Print five leading spaces.
Print #FileNumber, Tab(10); "Hello" ' Print word at column 10.
' Assign----------------------------------------
MyBool = False: MyDate = #2/12/1969#: MyNull = Null
MyError = CVErr(32767)
'-----------------------------------------------
Print #FileNumber, MyBool; " is a Boolean value"
Print #FileNumber, MyDate; " is a date"
Print #FileNumber, MyNull; " is a null value"
Print #FileNumber, MyError; " is an error value"
Print #FileNumber, ' 「blank line」の書き込み
End If
Case "シーケンシャルモード【読み込み】"
Open sFile For Input As #FileNumber
If CommandType = 1 Then
Do While Not EOF(FileNumber)
' Line Input # ステートメント
'変数へ設定
Line Input #FileNumber, MyString
'イミディエイトウィンドウ出力
Debug.Print MyString
Loop
ElseIf CommandType = 2 Then
Do While Not EOF(FileNumber)
'Input # ステートメント
'カンマ区切りで複数の変数指定
Input #FileNumber, MyNumber, MyString
'イミディエイトウィンドウ出力
Debug.Print MyNumber, MyString
Loop
End If
Case "Binary モード"
If CommandType = 1 Then
'出力モード
Open sFile For Binary Access Write As #FileNumber
'データ生成
For RecordNumber = 1 To 5
'MyRecord.ID = RecordNumber
'MyRecord.Name = "My Name" & RecordNumber
MyString = "My Name" & RecordNumber & VBA.vbTab
'ファイルへ書き込み
'Put ステートメント recordNumber 空欄
Put #FileNumber, , MyString 'MyRecord '配列も可
'イミディエイトウィンドウ出力
Debug.Print RecordNumber, MyString
Next
ElseIf CommandType = 2 Then
'入力モード 排他制御
Open sFile For Binary Access Read Lock Read As #FileNumber
'Get ステートメント recordNumber 空欄
MyString = VBA.Space(100)
Get #FileNumber, , MyString 'MyRecord '配列も可
'イミディエイトウィンドウ出力
Debug.Print MyString
'処理の比較
' For RecordNumber = 1 To 5
' If EOF(FileNumber) Then Exit For
' 'カンマ区切りで複数の変数指定
' Input #FileNumber, RecordNumber, MyString
' 'イミディエイトウィンドウ出力
' Debug.Print RecordNumber, MyString
' Next
Else
'Open sFile For Binary Access Read Write As #FileNumber '入出力モード
End If
Case "Random モード"
Open sFile For Random As #FileNumber Len = Len(MyRecord)
If CommandType = 1 Then
'データ生成
For RecordNumber = 1 To 5
MyRecord.ID = RecordNumber
MyRecord.Name = "My Name" & RecordNumber
' ファイルへ書き込み
'Put ステートメント
Put #FileNumber, RecordNumber, MyRecord
'イミディエイトウィンドウ出力
Debug.Print MyRecord.ID, MyRecord.Name
Next
ElseIf CommandType = 2 Then
'読み込み
Position = 3 ' レコード番号の指定
'Get ステートメント
Get #FileNumber, Position, MyRecord ' 読み込み
'イミディエイトウィンドウ出力
Debug.Print MyRecord.ID, MyRecord.Name
End If
End Select
'GO_Exit:
Close #FileNumber 'ファイルを閉じる
Exit Function
err_1:
If Err.Number <> 0 Then
Debug.Print "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
End If
'Resume GO_Exit
End Function
Y：行 X：列 R：ROW 備忘録：配列の宣言に（）を付けるとErase
Option Explicit
Sub 二次元配列_Sample()
Dim y As Double
Dim x As Double
Dim r As Double
Dim c As Double
Dim i As Double
Dim rsData As Variant
Dim setData As Variant
y = 5
x = 4
Set rsData = Nothing
ReDim rsData(y, x) 'vardata(固定, 変動)
Set setData = Nothing
ReDim setData(8)
setData(0) = 1
setData(1) = 2
setData(2) = 3
setData(3) = 4
setData(4) = 5
setData(5) = 6
setData(6) = 7
setData(7) = 8
setData(8) = 9
r = 0 '行の配列要素初期値
x = 0 '列の配列要素初期値
For i = 0 To 0
ReDim Preserve rsData(y, UBound(setData))
For c = LBound(setData) To UBound(setData)
rsData(r, x) = setData(c)
' Debug.Print rsData(r, x)
x = x + 1
Next
r = r + 1
Next
r = 0 '行の配列要素初期値
x = 0 '列の配列要素初期値
For c = LBound(setData) To UBound(setData)
Debug.Print rsData(r, x)
x = x + 1
Next
r = r + 1
End Sub
©Hirotoshi Takano