VBA Functionの内容

Excel VBAにLeft関数、Mid関数、Replace関数などの自身で処理を記入しなくても、VBA側で設定されている関数を呼び出せば毎回同じ処理が実行されます。

これと似たように、Functionを使用することによって自身で関数を作成出来ます。それを呼び出すことによって自身が作成した処理を毎回実行出来ます。

SubとFunctionの違い

簡単に言いますと戻り値が設定出来るか出来ないかの違いです。

Subは戻り値が設定出来ません。

Functionは戻り値も設定できます。

Functionの使用例

・引数なし、戻り値なしの場合

・引数あり、戻り値なしの場合

・渡す引数と受け取る引数の型が不一致の時に発生するエラー

・引数なし、戻り値ありの場合

・戻り値の型が不一致の時に発生するエラー

・引数あり、戻り値ありの場合

・引数複数、戻り値配列の場合

・ByValとByRefの違いについて

の内容で説明をしていきます。

引数なし、戻り値なしの場合

引数なし、戻り値なしの場合のFunctionの定義

Function 適当な名前()
    処理内容
End Function

メイン側がCallで呼び出しをします。

Sub メイン1()
    Call 引数と戻り値なし1()
End Sub
Function 引数と戻り値なし1()
    MsgBox "引数と戻り値なし1"
End Function

メイン側でCallを記入しないで呼び出しをします。

Sub メイン2()
    引数と戻り値なし2
End Sub
Function 引数と戻り値なし2()
    MsgBox "引数と戻り値なし2"
End Function

プログラマーによって記入方法が変わるので注意してください。

メイン側でFunctionではなくSubを使用した関数を呼び出します。

Sub メイン3()
    Call 引数と戻り値なし3()
End Sub
Sub 引数と戻り値なし3()
    MsgBox "引数と戻り値なし3"
End Sub

この様に戻り値がなければ、FunctionかSubのどちらでも問題ありません。

開発元のコーディングルールに基づいて開発を行って下さい。

引数あり、戻り値なしの場合

引数あり、戻り値なしの場合のFunctionの定義

Function 適当な名前(ByVal Or ByRef(省略可) 変数名 as データの型)
    処理内容
End Function

引数はByRefとByValの2つの記入方法があり、省略した場合はByRefが設定されます。

ByRefとByValは後程説明します。

メイン側がCallで呼び出しをします。

Sub メイン4()
    Dim text As String
    text = "引数あり戻り値なし4"
    Call 引数あり戻り値なし(text)
End Sub

()の中にString型を設定しています。

Function 引数あり戻り値なし(ByVal text As String)
    MsgBox text
End Function

引数を渡してそのまま表示しました。

メイン側でCallを記入しないで呼び出しをします。

Sub メイン5()
    Dim text As String
    text = "引数あり戻り値なし5"
    引数あり戻り値なし text
End Sub

引数あり戻り値なし関数の後に” “とtextを記入します。

Functionは変更していません。

Function 引数あり戻り値なし(ByVal text As String)
    MsgBox text
End Function

この様に引数に渡す内容を変更すれば結果が変わります。

メイン側でFunctionではなくSubを使用した関数を呼び出します。

Sub メイン6()
    Dim text As String
    text = "引数あり戻り値なし6"
    Call 引数あり戻り値なし6(text)
End Sub

FunctionをSubに変更しただけです。

Sub 引数あり戻り値なし6(ByVal text As String)
    MsgBox text
End Sub

渡す引数と受け取る引数の型が不一致の時に発生するエラー

エラーが発生する場合は大体コピペで中身を変更した時に発生します。

コピペをする時は注意して下さい。

ByValの場合

Sub メイン7()
    Dim text As String
    text = "あいう"
    Call ByValを利用(text)
End Sub

渡す引数はString型に設定しています。

Function ByValを利用(ByVal text As Integer)
    MsgBox text
End Function

受け取る側はInteger型に設定しています。

この時に処理を実行した場合に発生するエラーの内容です。

ByRefの場合

Sub メイン8()
    Dim text As Integer
    text = 4
    Call ByRefを利用(text)
End Sub

渡す引数はInteger型に設定しています。

Function ByRefを利用(ByRef text As String)
    MsgBox text
End Function

受け取る側はString型に設定しています。

この時に処理を実行した場合に発生するエラーの内容です。

渡す引数はInteger型で受け取る引数はString型なのでコンパイルエラーが発生します。

この様にByValとByRefでエラーの内容が変わりますので注意して下さい。

引数なし、戻り値ありの場合

引数なし、戻り値ありの場合のFunctionの定義

Function 適当な名前() As データの型
    処理内容
    適当な名前 = データの型
End Function

戻り値がある場合はFunctionで設定した名前に戻り値のデータを=で設定します。

Sub メイン9()
    Dim text As String
    text = 引数なし戻り値あり()   '()を省略する事も可能です。
    MsgBox text
End Sub

Function側で戻り値を設定している場合はCallを使用しません。

メイン側でFunctioの戻り値を受け取ります。

Function 引数なし戻り値あり() As String
    Dim text As String
    text = "String型が戻り値です"
    引数なし戻り値あり = text
End Function

Function側の戻り値は=で設定します。

Function側の戻り値が表示されました。

戻り値の型が不一致の時に発生するエラー

エラーが発生する場合は大体コピペで中身を変更した時に発生します。

コピペをする時は注意して下さい。

Sub メイン10()
    Dim i As Integer
    i = 引数なし戻り値あり() 
    MsgBox i
End Sub

受け取り側がIntegerで受け取っています。

Function 引数なし戻り値あり() As String
    Dim text As String
    text = "String型が戻り値です"
    引数なし戻り値あり = text
End Function

戻り値はString型で戻しています。

処理の実行時に実行時エラー’13’が発生します。

引数あり、戻り値ありの場合

引数あり、戻り値ありの場合のFunctionの定義

Function 適当な名前(ByVal Or ByRef(省略可) 変数名 as データの型) As データの型
    処理内容
    適当な名前 = データの型
End Function

メイン側でFunction側の戻り値を”=”で受け取ります。

Sub メイン11()
    Dim text As String
    text = "あいう"
    text = 引数あり戻り値あり(text)
    MsgBox text
End Sub

メイン側でtextの内容を”あいう”で設定します。

Function 引数あり戻り値あり(ByVal text As String) As String
    text = "えおか"
    引数あり戻り値あり = text
End Function

Function側で戻り値を”えおか”に設定します。

メイン側で”えおか”が表示されました。

引数複数、戻り値配列の場合

引数複数、戻り値配列の場合のFunctionの定義

Function プロシージャ名(ByVal 引数名1 As データ型, ByVal 引数名2 As データ型, ・・・) As 戻り値のデータ型()
        処理内容
	プロシージャ名 = 戻り値()
End Function

メイン側で配列を受け取れるように配列の変数を設定します。

Sub メイン12()
    Dim text1, text2, text3 As String
    Dim textList() As String
    text1 = "あいう"
    text2 = "aiu"
    text3 = "アイウ"
    
    textList = リスト作成(text1, text2, text3)
    MsgBox textList(0) + "," + textList(1) + "," + textList(2)
End Sub

text1,2,3に”あいう”,”aiu”,”アイウ”を設定してFunction側を呼び出します。

Function側の戻り値はString型の配列なのでString型の配列で受け取ります。

Function リスト作成(ByVal text1 As String, ByVal text2 As String, ByVal text3 As String) As String()
    Dim list(2) As String
    
    list(0) = text1
    list(1) = text2
    list(2) = text3
    
    リスト作成 = list()
End Function

Function側でlistの配列の要素数をlist(2)と設定しています。

配列は0番目から設定するので3つのデータを設定したい場合は要素数を2に設定しました。

textListが設定されて表示出来ました。

ByValとByRefの違いについて

ByValは引数をFunction側に値を渡すだけです。

ByValを使った引数渡しを値渡しといいます。

ByRefは引数をFunction側に値を渡すだけではなく、Function側で引数が変更されても呼び出し側でも変更後の値を取得します。

ByRef句を使った引数渡しを参照渡しといいます。

ByValの場合

Sub メイン13()
    Dim text As String
    text = "あいう"
    
    Call ByVal使用(text)
    MsgBox text
    
End Sub

Function ByVal使用(ByVal text As String)

    'あいうからabcに変更
    text = "abc"
End Function

メイン側でtextに”あいう”を設定してFunction側を呼び出しています。

Function側は”あいう”を”abc”に変更しています。

結果は”あいう”が表示されました。

ByRefの場合

Sub メイン14()
    Dim text As String
    text = "あいう"
    
    Call ByRef使用(text)
    MsgBox text
    
End Sub

Function ByRef使用(ByRef text As String)
    'あいうからabcに変更
    text = "abc"
End Function

ByValをByRefに変更しました。

他の処理内容は先ほどと変わりません。

結果が”abc”に変更されました。

この様にByRefを使用すると引き渡された変数の内容が変更後の値に設定されます。

戻り値を設定しなくても値が変更出来ます。複数の引数の値を変更したい時に便利です。

注意点として色々な所でByRefを使用すると処理内容を変更する時に処理を追うのが大変になるので気を付けて下さい。

今回はFunctionについて説明をさせて頂きました。

皆様の参考になれば幸いです。

文字列の内容 Replace関数

Replace関数は文字列を置換する関数です。

標記を統一させたい時などに使用します。

Replace関数の構文

Replace(String, Find, Replace)

Replace(文字列, 検索する文字列, 置換する文字列)

[]内は省略可能です。

Replace(String, Find, Replace, [ start, count, compare])

Replace(文字列, 検索する文字列, 置換する文字列, [ 置換する開始位置 , 置換する回数 , 比較方法 ])

Replace関数の使用例

・Replace関数内に文字列を直接設定

・文字列に検索する文字列が無い場合

・Replace関数内の文字列が空白の場合

・Replace関数内の検索する文字列が空白の場合

・Replace関数内の置換する文字列が空白の場合

・Replace関数で置換する開始位置を設定

・Replace関数で置換する回数を設定

・Replace関数で比較方法を設定

・文字列を変数に設定

・セルから文字列を取得してセルに設定

繰り返し処理(検索する文字列)

・繰り返し処理(文字列、検索する文字列)

・繰り返し処理(文字列、検索する文字列、置換する文字列)

の内容で説明していきます。

Replace関数内に文字列を直接設定

Sub Replace1()
    
    MsgBox Replace("acbcdcec", "c", "f")

End Sub

“c”が”f”に置換されました。

文字列に検索する文字列が無い場合

Sub Replace2()
    
    MsgBox Replace("acbcdcec", "k", "f")

End Sub

文字列内にkがないのでそのまま表示されます。

Replace関数内の文字列が空白の場合

Sub Replace3()
    
    MsgBox Replace("", "c", "f")

End Sub

文字列が空白なので表示されません。

Replace関数内の検索する文字列が空白の場合

Sub Replace4()
    
    MsgBox Replace("acbcdcec", "", "f")

End Sub

検索する文字列がないためそのまま表示されます。

Replace関数内の置換する文字列が空白の場合

Sub Replace5()
    
    MsgBox Replace("acbcdcec", "c", "")

End Sub

置換する文字を空白に設定しているため”c”が空白になり”abde”が表示されます。

Replace関数で置換する開始位置を設定

Sub Replace6()
    
    MsgBox Replace("acbcdcec", "c", "f", 2)

End Sub

開始位置を2文字目に設定したため先頭の”a”が表示されません。

開始位置を省略した場合は先頭から表示されます。

Replace関数で置換する回数を設定

Sub Replace8()
    
    MsgBox Replace("acbcdcec", "c", "f", , 3)

End Sub

置換する回数を3回に設定したため、末尾の”c”が4回目になるので”c”が置換されません。

置換する回数を設定しない場合は、文字列のすべての候補を置換します。

Replace関数で比較方法を設定

Sub Replace9()
    
    MsgBox Replace("cCcC", "c", "f", , , 0)

End Sub

比較方法を0に設定した場合、先頭の”c”だけが”f”に置換されました。

Sub Replace10()
    
    MsgBox Replace("cCcC", "c", "f", , , 1)

End Sub

比較方法を1に設定した場合、すべて”f”に置換されました。

比較方法が0の場合は大小半角全角文字を判定します。

比較方法が1の場合は大小半角全角文字を判定しません。

比較方法を省略した場合は0が設定されます。

Sub Replace11()
    
    MsgBox Replace("cCcC", "c", "f", , , vbBinaryCompare)

End Sub
Sub Replace12()
    
    MsgBox Replace("cCcC", "c", "f", , , vbTextCompare)

End Sub

比較方法の設定が0と1ではなく、vbBinaryCompareとvbTextCompareの記載も可能です。

問題1

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Replace13()
    
    MsgBox Replace("acbcdcecgc", "c", "f", 3, 3)

End Sub

問題2

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Replace14()
    
    MsgBox Replace("acbcCcCdce", "c", "f", 2, 3, 1)

End Sub

問題1の答え

Replace(“acbcdce”, “c”, “f”, 2, 3)

開始位置が3、置換回数が3のため、先頭の”ac”が表示されず、末尾の”c”が4回目のため置換されていません。

問題2の答え

Replace(“acbcCcCdce”, “c”, “f”, 2, 3, 1)

開始位置が2、置換する回数が3、比較方法が1のため、先頭の”a”が表示されず、置換する回数が3回なので大文字の”C”まで”f”に置換されます。

文字列を変数に設定

Sub Replace15()
    Dim str, find, rep As String
    str = "あいうえお"
    find = "い"
    rep = "か"
    
    MsgBox Replace(str, find, rep)

End Sub

“い”が”か”に置換されています。

セルから文字列を取得してセルに設定

Sub Replace16()
    Dim str, find, rep As String
    str = Cells(2, 2)
    find = Cells(2, 3)
    rep = Cells(2, 4)
    
    Cells(2, 5) = Replace(str, find, rep)

End Sub

“い”が”か”に置換されました。

繰り返し処理(検索する文字列)

Sub Replace17()
    Dim str, rep As String
    Dim find() As String
    Dim i, retuNum As Integer
    str = Cells(2, 2)
    rep = Cells(2, 4)
    '検索する文字列の列番号を設定します
    retuNum = 3
    '検索する文字列のリストを設定します
    find() = リストの設定(retuNum)
    
    i = 1
    '文字列の置換をリスト分繰り返します
    For Each Var In find
        str = Replace(str, find(i - 1), rep)
        i = i + 1
    Next
    
    Cells(2, 5) = str

End Sub

今回はFunctionを使用しています。

Functionの内容は検索のリストを作成して返却しています。

Function リストの設定(ByVal retuNum As Integer) As String()
    
    Dim list() As String
    Dim i As Integer
    Dim kazu As Long
    
    kazu = Cells(1000, retuNum).End(xlUp).Row
    ReDim list(kazu - 2)
    
    For i = 2 To kazu
        list(i - 2) = Cells(i, retuNum)
    Next i
    
    リストの設定 = list()
    
End Function

複数の記号がすべて”-“に変換されました。

繰り返し処理(文字列、検索する文字列)

Sub Replace18()
    Dim rep As String
    Dim str() As String
    Dim find() As String
    Dim i, j, retuNum As Integer
    
    rep = Cells(2, 4)
    
    '文字列の列番号を設定します
    retuNum = 2
    '検索する文字列のリストを設定します
    str() = リストの設定(retuNum)
    
    '検索する文字列の列番号を設定します
    retuNum = 3
    '検索する文字列のリストを設定します
    find() = リストの設定(retuNum)
    
    i = 1
    '文字列をリスト分繰り返します
    For Each Var In str
        j = 1
        '文字列の置換をリスト分繰り返します
        For Each Var2 In find
            str(i - 1) = Replace(str(i - 1), find(j - 1), rep)
            j = j + 1
        Next
        Cells(i + 1, 5) = str(i - 1)
        i = i + 1
    Next
    
End Sub

Functionは文字列のリストと検索のリストの内容を返却しています。

Function リストの設定(ByVal retuNum As Integer) As String()
    
    Dim list() As String
    Dim i As Integer
    Dim kazu As Long
    
    kazu = Cells(1000, retuNum).End(xlUp).Row
    ReDim list(kazu - 2)
    
    For i = 2 To kazu
        list(i - 2) = Cells(i, retuNum)
    Next i
    
    リストの設定 = list()
    
End Function

置換する文字列が1行毎に置換されました。

繰り返し処理(文字列、検索する文字列、置換する文字列)

検索文字と置換文字は#→a、%→b、$→c、!→d、”→e、&→fという内容で置換します。

Sub Replace19()
    Dim str() As String
    Dim find() As String
    Dim rep() As String
    Dim i, j, retuNum As Integer
    
    '文字列の列番号を設定します
    retuNum = 2
    '検索する文字列のリストを設定します
    str() = リストの設定(retuNum)
    
    '検索する文字列の列番号を設定します
    retuNum = 3
    '検索する文字列のリストを設定します
    find() = リストの設定(retuNum)
    
    '置換する文字列の列番号を設定します
    retuNum = 4
    '置換する文字列のリストを設定します
    rep() = リストの設定(retuNum)
    
    i = 1
    '文字列をリスト分繰り返します
    For Each Var In str
        j = 1
        '文字列の置換をリスト分繰り返します
        For Each Var2 In find
            str(i - 1) = Replace(str(i - 1), find(j - 1), rep(j - 1))
            j = j + 1
        Next
        Cells(i + 1, 5) = str(i - 1)
        i = i + 1
    Next
    
End Sub

Functionは文字列のリスト、検索のリストと置換のリストの内容を返却しています。

Function リストの設定(ByVal retuNum As Integer) As String()
    
    Dim list() As String
    Dim i As Integer
    Dim kazu As Long
    
    kazu = Cells(1000, retuNum).End(xlUp).Row
    ReDim list(kazu - 2)
    
    For i = 2 To kazu
        list(i - 2) = Cells(i, retuNum)
    Next i
    
    リストの設定 = list()
    
End Function

それぞれ対応している文字が置換されました。

str(i – 1) = Replace(str(i – 1), find(j – 1), rep(j – 1))を

str(i – 1) = Replace(str(i – 1), find(j – 1), rep(j – 1), , , 1)に変更すれば大小全角半角を判定せずに置換されます。

今回はReplace関数について記載させて頂きました。

少しでも皆様の参考になれば幸いです。

文字列の内容 Mid関数

Mid関数は文字列の指定した位置から指定した文字数を取得する関数です。

簡単に言うと文字の抜き取りです。

Mid関数の構文

Mid( String , Start)

Mid( 文字列 , 文字列の指定した位置 )

Mid( String , Start , Length)

Mid( 文字列 , 文字列の指定した位置 , 取得したい文字数 )

Mid関数の使用例

・Mid関数内に文字列を直接設定

・Mid関数内に文字列がないの場合

・文字列を変数に設定

・Mid関数内で文字列の結合

・セルから文字列を取得して隣のセルに設定

繰り返し処理(for文)

・繰り返し処理(Do While文)

の内容で説明していきます。

Mid関数内に文字列を直接設定

Sub Mid01()
    
    MsgBox Mid("abcde", 3)

End Sub

取得したい文字数を指定しなければ3文字目から末尾まで表示されます。

Sub Mid02()
    
    MsgBox Mid("abcde", 3, 2)

End Sub

取得したい文字数を2に指定した場合は3文字目から2文字表示されます。

Mid関数内に文字列がないの場合

Sub Mid1()
    
    MsgBox Mid("", 3)

End Sub

文字列がないためメッセージボックス内には何も表示されません。

文字列を変数に設定

Sub Mid2()
    Dim str As String
    str = "abcde"
    
    MsgBox Mid(str, 3, 2)

End Sub

str = abcdeなので3文字目から2文字までのcdが表示されます。

Mid関数内で文字列の結合

Sub Mid3()
    Dim str As String
    str = "abcde"
    
    MsgBox Mid(str + "fgh", 7, 2)

End Sub

Mid関数の文字列は”abcde”+”fgh”=”abcdefgh”になります。

そこから7文字目から2文字なのでghで表示されます。

問題1

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Mid4()
    Dim str As String
    str = "あいうえお"
    
    MsgBox Mid(str, 2, 2)

End Sub

問題2

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Mid5()
    Dim str1, str2 As String
    str1 = "あいうえお"
    str2 = "かきくけこ"
    
    MsgBox Mid(str1 + str2, 2 + 5, 2 + 1)

End Sub

問題1の答え

str = “あいうえお”でしたので2文字目から2文字ですので”いう”が表示されます。

問題2の答え

Mid(str1 + str2, 2 + 5, 2 + 1)

Mid(“あいうえおかきくけこ”, 7 , 3 )になるため”きくけ”が表示されます。

セルから文字列を取得して隣のセルに設定

B2から文字列を取得してC2に設定します。

Sub Mid6()
    Dim str As String
    str = Range("B2").Value
    
    Range("C2").Value = Mid(str, 3, 2)

End Sub

処理の実行

cdの値がC2のセルに設定されました。

同様の処理内容

Mid関数内にRange(“B2”)を設定する。

Sub Mid7()
    
    Range("C2").Value = Mid(Range("B2").Value, 3, 2)

End Sub

Rangeではなく、Cellsで設定する。

Sub Mid8()
    Dim str As String
    str = Cells(2, 2)
    
    Cells(2, 3) = Mid(str, 3, 2)

End Sub

上記、2つの処理でもcdの値がC2のセルに設定されます。

Cellsのイメージ

繰り返し処理(for文)

B列に取得したい文字列が8行入力されています。

これを繰り返し処理でC列に3文字目から2文字まで取得して表示させます。

処理内容

Sub Mid9()
    Dim str As String
    Dim i As Integer
    
    For i = 1 To 8
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Mid(str, 3, 2)
    Next

End Sub

処理の結果

8行分3文字目から2文字まで取得できました。

繰り返し処理(Do While文)

for文ではFor i = 1 To 8と記載して8回処理をしたら終了する設定にしました。

Do While文では終了条件で繰り返し処理を終了させます。

終了条件はB列が空白になるまで繰り返し処理を行います。

つまりB10まで繰り返し処理を行います。

処理内容

Sub Mid10()
    Dim str As String
    Dim i As Integer
    
    i = 1
    
    Do While Cells(i + 1, 2) <> ""
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Mid(str, 3, 2)
        i = i + 1  'この処理が抜けると無限ループになります。

    Loop

End Sub

Do While Cells(i + 1, 2) <> “”で空白でない限り処理を繰り返します。

処理の結果

for文と結果は変わりませんがB列が空白でない限り処理が実行されます。

今回はMid関数を使用した使用例を複数記載致しました。

皆様の参考になれば幸いです。

文字列の内容 Right関数

Right関数は文字列を末尾から指定した文字数分だけ取得する関数です。

簡単に言うと文字の抜き取りです。

Right関数の構文

Right( String , Length )

Right( 文字列 , 抜き出したい文字数 )

Right関数の使用例

・Right関数内に文字列を直接設定

・Right関数内に文字列がないの場合

・文字列を変数に設定

・Right関数内で文字列の結合

・セルから文字列を取得して隣のセルに設定

繰り返し処理(for文)

・繰り返し処理(Do While文)

の内容で説明していきます。

Right関数内に文字列を直接設定

Sub Right0()
    
    MsgBox Right("abcde", 3)

End Sub

末尾から3文字目まで表示されます。

Right関数内に文字列がないの場合

Sub Right1()
    
    MsgBox Right("", 3)

End Sub

文字列がないためメッセージボックス内には何も表示されません。

文字列を変数に設定

Sub Right2()
    Dim str As String
    str = "abcde"
    
    MsgBox Right(str, 3)

End Sub

str = abcdeなので末尾から3文字までのcdeが表示されます。

Right関数内で文字列の結合

Sub Right3()
    Dim str As String
    str = "abcde"
    
    MsgBox Right(str + "fgh", 7)

End Sub

Right関数の文字列は”abcde”+”fgh”=”abcdefgh”になります。

そこから末尾から7文字なのでbcdefghで表示されます。

問題1

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Right4()
    Dim str As String
    str = "あいうえお"
    
    MsgBox Right(str, 2)

End Sub

問題2

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Right5()
    Dim str1, str2 As String
    str1 = "あいうえお"
    str2 = "かきくけこ"
    
    MsgBox Right(str1 + str2, 2 + 5)

End Sub

問題1の答え

str = “あいうえお”でしたので末尾からの2文字ですので”えお”が表示されます。

問題2の答え

Right(“あいうえお” + “かきくけこ”, 2 + 5)

Right(“あいうえおかきくけこ”, 7)になるため”えおかきくけこ”が表示されます。

セルから文字列を取得して隣のセルに設定

B2から文字列を取得してC2に設定します。

Sub Right6()
    Dim str As String
    str = Range("B2").Value
    
    Range("C2").Value = Right(str, 3)

End Sub

処理の実行

cdeの値がC2のセルに設定されました。

同様の処理内容

Right関数内にRange(“B2”)を設定する。

Sub Right7()
    
    Range("C2").Value = Right(Range("B2").Value, 3)

End Sub

Rangeではなく、Cellsで設定する。

Sub Right8()
    Dim str As String
    str = Cells(2, 2)
    
    Cells(2, 3) = Right(str, 3)

End Sub

上記、2つの処理でもcdeの値がC2のセルに設定されます。

Cellsのイメージ

繰り返し処理(for文)

B列に取得したい文字列が8行入力されています。

これを繰り返し処理でC列に末尾から3文字取得して表示させます。

処理内容

Sub Right9()
    Dim str As String
    Dim i As Integer
    
    For i = 1 To 8
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Right(str, 3)
    Next

End Sub

処理の結果

8行分末尾から3文字まで取得できました。

繰り返し処理(Do While文)

for文ではFor i = 1 To 8と記載して8回処理をしたら終了する設定にしました。

Do While文では終了条件で繰り返し処理を終了させます。

終了条件はB列が空白になるまで繰り返し処理を行います。

つまりB10まで繰り返し処理を行います。

処理内容

Sub Right10()
    Dim str As String
    Dim i As Integer
    
    i = 1
    
    Do While Cells(i + 1, 2) <> ""
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Right(str, 3)
        i = i + 1  'この処理が抜けると無限ループになります。

    Loop

End Sub

Do While Cells(i + 1, 2) <> “”で空白でない限り処理を繰り返します。

処理の結果

for文と結果は変わりませんがB列が空白でない限り処理が実行されます。

今回はRight関数を使用した使用例を複数記載致しました。

皆様の参考になれば幸いです。

次回はMid関数の使用例を投稿致します。

文字列の内容 Left関数

Left関数は文字列を先頭から指定した文字数分だけ取得する関数です。

簡単に言うと文字の抜き取りです。

Left関数の構文

Left( String , Length )

Left( 文字列 , 抜き出したい文字数 )

Left関数の使用例

・Left関数内に文字列を直接設定

・Left関数内に文字列がないの場合

・文字列を変数に設定

・Left関数内で文字列の結合

・セルから文字列を取得して隣のセルに設定

繰り返し処理(for文)

・繰り返し処理(Do While文)

の内容で説明していきます。

Left関数内に文字列を直接設定

Sub Left()
    
    MsgBox Left("abcde", 3)

End Sub

先頭文字から3文字目まで表示されます。

Left関数内に文字列がないの場合

Sub Left1()
    
    MsgBox Left("", 3)

End Sub

文字列がないためメッセージボックス内には何も表示されません。

文字列を変数に設定

Sub Left2()
    Dim str As String
    str = "abcde"
    
    MsgBox Left(str, 3)

End Sub

str = abcdeなので先頭から3文字までのabcが表示されます。

Left関数内で文字列の結合

Sub Left3()
    Dim str As String
    str = "abcde"
    
    MsgBox Left(str + "fgh", 7)

End Sub

Left関数ないの文字列は”abcde”+”fgh”=”abcdefgh”になります。

そこから先頭から7文字なのでabcdefgで表示されます。

問題1

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Left4()
    Dim str As String
    str = "あいうえお"
    
    MsgBox Left(str, 2)

End Sub

問題2

以下の内容を実行したときにメッセージボックスに表示される内容はどの様になりますか。

Sub Left5()
    Dim str1, str2 As String
    str1 = "あいうえお"
    str2 = "かきくけこ"
    
    MsgBox Left(str1 + str2, 2 + 5)

End Sub

問題1の答え

str = “あいうえお”でしたので先頭からの2文字ですので”あい”が表示されます。

問題2の答え

Left(“あいうえお” + “かきくけこ”, 2 + 5)

Left(“あいうえおかきくけこ”, 7)になるため”あいうえおかき”が表示されます。

セルから文字列を取得して隣のセルに設定

B2から文字列を取得してC2に設定します。

Sub Left6()
    Dim str As String
    str = Range("B2").Value
    
    Range("C2").Value = Left(str, 3)

End Sub

処理の実行

abcの値がC2のセルに設定されました。

同様の処理内容

Left関数内にRange(“B2”)を設定する。

Sub Left7()
    
    Range("C2").Value = Left(Range("B2").Value, 3)

End Sub

Rangeではなく、Cellsで設定する。

Sub Left8()
    Dim str As String
    str = Cells(2, 2)
    
    Cells(2, 3) = Left(str, 3)

End Sub

上記、2つの処理でもabcの値がC2のセルに設定されます。

Cellsのイメージ

繰り返し処理(for文)

B列に取得したい文字列が8行入力されています。

これを繰り返し処理でC列に先頭から3文字取得して表示させます。

処理内容

Sub Left9()
    Dim str As String
    Dim i As Integer
    
    For i = 1 To 8
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Left(str, 3)
    Next

End Sub

処理の結果

8行分先頭から3文字まで取得できました。

しかし、最後から2行の文字列は数値で表示されました。

VBA側で文字列として処理をしてもExcel側で数値に変換されます。

この表示を修正するにはセルの書式設定で文字列として表示させましょう。

これで数値が正常に文字列として表示されます。

繰り返し処理(Do While文)

for文ではFor i = 1 To 8と記載して8回処理をしたら終了する設定にしました。

Do While文では終了条件で繰り返し処理を終了させます。

終了条件はB列が空白になるまで繰り返し処理を行います。

つまりB10まで繰り返し処理を行います。

処理内容

Sub Left10()
    Dim str As String
    Dim i As Integer
    
    i = 1
    
    Do While Cells(i + 1, 2) <> ""
        str = Cells(i + 1, 2)
    
        Cells(i + 1, 3) = Left(str, 3)
        i = i + 1  'この処理が抜けると無限ループになります。
    Loop

End Sub

Do While Cells(i + 1, 2) <> “”で空白でない限り処理を繰り返します。

処理の結果

for文と結果は変わりませんがB列が空白でない限り処理が実行されます。

今回はLeft関数を使用した使用例を複数記載致しました。

皆様の参考になれば幸いです。

次回はRight関数の使用例を投稿致します。

指定したフォルダにあるファイルをコピーしてファイル名を変更して貼り付けの処理内容

前回の内容のファイル名を変更して貼り付けの処理の説明を行います。

ファイル名の変更処理を行っている内容

フォルダを指定してファイルをコピーして、ファイル名を変更して出力先のフォルダに貼り付けを行っています。

処理の説明

メイン処理

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    '枚数の初期設定をします。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub

メイン処理ではB1とB2にパスが指定されているか判定を行い。入力がされていた場合はファイル名変更のメソッドを呼び出します。

ここでのメソッドは自分で作成した関数みたいものです。

ファイル名変更の処理内容

Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

上記で行っている処理の内容

受け取ったパス内にファイルが存在する分だけ処理を繰り返す。

ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け。

受け取ったパス内にフォルダが存在する分だけ処理を繰り返す。

サブフォルダのパスをファイル名変更メソッドに渡す。

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

ファイル名変更()の処理を行っている最中にさらにファイル名変更()を呼び出す処理を再帰処理といいます。要は同じ処理を呼び出しているだけです。

再帰処理のイメージ

ファイルのコピーの内容

    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile

フォルダの指定した位置からサブフォルダに含まれるファイルのパスを取得して、フォルダの指定した場所からファイルの間のサブフォルダ名をファイル名に設定しています。

例 

フォルダの指定 C:\Users\nekon\Desktop\仕事\ファイル一覧

ファイルの位置 C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

ファイル名を取得

file = objFile.Name

file = IMG00012.jpg

ファイルのパスを取得

filePath = objFile.Path

filePath = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピーしたいファイルのサブフォルダ名の抜き出し

fileName = Mid(filePath, Len(Range(“B1”)) + 1, Len(filePath) – Len(Range(“B1”)) – Len(file))

fileName = \場所(1)\工事(1)\

\を_に変換

fileName = Replace(fileName, “\”, “_”)

fileName = _場所(1)_工事(1)_

拡張子の取得

kakucho = Mid(file, InStr(file, “.”))

kakucho = .jpg

出力先のパスを設定

syuturyokuPath = Range(“B2”).Value + “\”

syuturyokuPath = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\

施工状況の設定

        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select

iを3で割った余りで施工前中後を設定している。

ファイル名を変更して貼り付け

FileCopy コピー元のファイルパス , コピー先のファイルパス

FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho

コピー元 = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピー先 = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\&1&_場所(1)_工事(1)_&施工前&.jpg

maisuはファイルをコピーした数です。

処理全体の内容

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    'ファイル名一覧を出力する行番号を指定します。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub




Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

ファイル名を変更して貼り付け処理の説明を終わります。

今回の内容で写真一括貼り付けの自動化を完了とします。また、処理を思いついたら追加していきます。

次回は文字列を取得してどの様な処理を行えるか記載していきたいと思います。

指定したフォルダにあるファイルをコピーしてファイル名を変更して貼り付け

前回の写真の一括貼り付け処理の内容でファイル名から文字列を取得して各項目に設定する方法を行いました。

そこでVBAが正常に動くか確認を行うため、テストファイルを作成するのに50枚の写真のファイル名を変更致しました。

50枚のファイル名を変更するのに15分ぐらいの時間と簡単な文字の入力を行ったのですが拷問の様な作業に感じたのでフォルダ名を参照しファイル名を自動で変更するマクロを組みました。

ファイル名の変更処理を行っている内容

指定したフォルダの下にある全てのフォルダのファイルからファイルをコピーして、出力先のフォルダにファイル名を変更して貼り付けを行います。

ファイル名の変更内容のルールとしてファイルの数とファルダ名を取得してファイル名に設定しています。

ファイル名のルール 番号_フォルダ名(場所)_フォルダ名(工事)_施工前中後

Excelファイル

フォルダの指定とファイルを貼り付ける位置を設定しています。

フォルダの指定

青枠で囲ってあるフォルダ内の全てのファイルをコピーします。

工事フォルダ全てに3つのファイルを置いてあります。

出力先フォルダ

処理の実行

ファイル名を変更して貼り付け

ファイル一覧フォルダの下にある全てのファイルをコピーして貼り付けています。

ファイル名取得処理の内容

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    '枚数の初期設定をします。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub




Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

今回はVBA上からファイル名のコピーをしてファイル名を変更して貼り付けを行いました。

次回は処理の説明を行います。

ファイル名から文字列の取得

写真の一括貼り付けを行う時に写真の貼り付けたい順番とファイル名を決めます。

名前の付け方にルールを決めてファイル名を取得して、セルに値を設定する様に致しました。

ファイル名から文字列を取得して各項目に設定

ファイル名の決め方

ファイル名  1_場所_工事_花(1).jpg

表示したい順番、場所、工事種目、施工状況の間に”_“を設定しています。

今回は”_“を判断材料として使用しているだけです。

判断材料はファイルの命名規則に問題なければ何でも大丈夫です。

例 “.””\”等はファイルの命名上問題が発生します。

写真毎に各項目のセルに値を設定

処理の説明

変数の宣言

    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String

検索文字の初期設定

    '検索文字の初期設定
    kensakuMoji = "_"

文字列検索

fileにファイル名が設定されています。

        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")

InStrでファイル名にある”_”の位置を取得しています。

各項目のセルに文字列を設定

        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou

Midで文字列を抜き出しています。

Cellsで抜き出した値をセルに設定しています。

処理全体の内容

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    '写真の一覧を取得
    Dim fileName As Variant
    Dim dblscal As Double
    Dim str As String
    
    Dim day As Date
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim filePath As Variant
    Dim file As Variant
    
'←--------追加
    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String
'---------->
  
    Dim startTime As Double
    Dim endTime As Double
    Dim processTime As Double
    
  
    fileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '画像ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(fileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    
'←------追加
    '検索文字の初期設定
    kensakuMoji = "_"
'---------->
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    'シェルの設定
    Set ObjShell = CreateObject("Shell.Application")
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(fileName) To UBound(fileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            fileName:=fileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left + 1, _
            Top:=ActiveCell.Top + 1, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        Cells(k, j).Select
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
        'ファイルのパスを取得
        filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
        'ファイル名の取得
        file = Mid(fileName(i), Len(filePath) + 1)
        
        '写真のデータを参照
        Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

        '写真の撮影日を取得
        day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
        '写真のデータの参照を解放
        Set ObjFolder = Nothing
        '写真の撮影日をセルに設定
        Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
        
'←------追加
        '文字列検索
        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")
        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou
'-------→
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
    
    'シェルの解放
    Set ObjShell = Nothing
    
    i = i - 1
    k = k - 20
    
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    

    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

今回の内容で各項目に値を設定する事が出来ました。

写真の一括貼り付け処理はエクセル上での操作でファイルを取得すれば自動で各項目に設定するため、自動化完了とします。

また、処理など思いつけば機能の追加を行います。

写真の撮影日取得の処理の説明

報告書の作成で写真を撮影した日にち取得する処理の説明を行います。

写真一括貼り付けの追加処理の内容

写真のデータから撮影日を取得してセルに設定しています。

変数の宣言

    Dim day As Date
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim filePath As Variant
    Dim file As Variant

シェルの設定

Set ObjShell = CreateObject("Shell.Application")

shellの設定でExcelからファイルの操作を行えるようにします。

ファイルのパスの取得

filePath = Left(fileName(i), InStrRev(fileName(i), "\"))

ファイル名の取得

file = Mid(fileName(i), Len(filePath) + 1)

例として、C:\Users\nekon\Desktop\仕事\写真\IMG00012.jpgの内容がfileName(i)に入っているとします。

fileName(i) = C:\Users\nekon\Desktop\仕事\写真\IMG00012.jpg

ファイルパスの取得は右から”\”の記号を検索して見つけた位置までの情報を設定しています。

InStrRev(fileName(i), “\”)で位置を検索して29の数値が見つかります。

Left(fileName(i), InStrRev(fileName(i), “\”))

Left(fileName(i), 29)になり

Left(fileName(i), 29) は C:\Users\nekon\Desktop\仕事\写真\ となります。

filePath = Left(fileName(i), 29)

filePath = C:\Users\nekon\Desktop\仕事\写真\

ファイル名の取得はfileName(i)からfilePathの内容を抜いた文字列を設定しています。

C:\Users\nekon\Desktop\仕事\写真\IMG00012.jpgから

C:\Users\nekon\Desktop\仕事\写真\を抜いて

IMG00012.jpgを設定しています。

写真データの参照

Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

写真の撮影日を取得

day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")

写真のデータの参照を解放

Set ObjFolder = Nothing

セルに撮影日を設定

Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")

シェルの解放

Set ObjShell = Nothing

写真一括貼り付け処理

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    '写真の一覧を取得
    Dim fileName As Variant
    Dim dblscal As Double
    Dim str As String
    
'←--------追加
    Dim day As Date
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim filePath As Variant
    Dim file As Variant
    
'---------->
  
    Dim startTime As Double
    Dim endTime As Double
    Dim processTime As Double
    
  
    fileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '画像ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(fileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    '開始時間取得
    startTime = Timer
    
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    
'←--------追加
    'シェルの設定
    Set ObjShell = CreateObject("Shell.Application")
'-------→
    
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(fileName) To UBound(fileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            fileName:=fileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left, _
            Top:=ActiveCell.Top, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        Cells(k, j).Select
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
'←------追加
        'ファイルのパスを取得
        filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
        'ファイル名の取得
        file = Mid(fileName(i), Len(filePath) + 1)
        
        '写真のデータを参照
        Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

        '写真の撮影日を取得
        day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
        '写真のデータの参照を解放
        Set ObjFolder = Nothing
        Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
        
'-------→
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
    
'←--------追加
    'シェルの解放
    Set ObjShell = Nothing
'-------→
    
    i = i - 1
    k = k - 20
    
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    
    '終了時間取得
    endTime = Timer
    
    '処理時間表示
    processTime = endTime - startTime
    MsgBox "処理時間:" & processTime
    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

写真一括貼り付けの撮影日を取得の処理内容の説明でした。

次回はさらに機能の追加を致します。

写真の撮影日の取得機能の追加

報告書の作成で写真の貼り付ける場合は撮影した日時を記載する事が多いため、写真データから撮影日の取得機能を追加致しました。

写真の撮影日を日程の隣のセルに表示する様に設定

撮影日が日程の隣のセルに表示されています。

写真を複数枚選択しても写真毎に撮影日を取得

選択しているファイルの撮影日が表示されています。

写真貼り付けの処理(撮影日を取得を追加)

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    '写真の一覧を取得
    Dim fileName As Variant
    Dim dblscal As Double
    Dim str As String
    
'←--------追加
    Dim day As Date
    Dim ObjShell      As Object
    Dim ObjFolder     As Object
    Dim filePath As Variant
    Dim file As Variant
    
'---------->
    
    fileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '画像ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(fileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    
'←--------追加
    'シェルの機能の参照
    Set ObjShell = CreateObject("Shell.Application")
'-------→
    
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(fileName) To UBound(fileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            fileName:=fileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left, _
            Top:=ActiveCell.Top, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        Cells(k, j).Select
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
'←------追加
        'ファイルのパスを取得
        filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
        'ファイル名の取得
        file = Mid(fileName(i), Len(filePath) + 1)
        
        '写真のデータを参照
        Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

        '写真の撮影日を取得
        day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
        '写真のデータの参照を解放
        Set ObjFolder = Nothing
        Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
        
'-------→
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
    
'←--------追加
    'シェルの解放
    Set ObjShell = Nothing
'-------→
    
    i = i - 1
    k = k - 20
    
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

処理の追加部分は←—-追加と表記しています。

次回は追加部分の処理の説明を行います。