Excelで直前に参照していたシートに戻る(シートの参照履歴を保持する)

VBA EXCEL


Excelで直前に参照していたシートに戻る方法について書きます。


Excelの標準機能では、以下のショートカットでシートを移動できます。

  (1) Ctrl+PageUP…左のシートへ移動

  (2) Ctrl+PageDown…右のシートへ移動






(図：Excel標準機能によるシート間の移動)


しかし、たくさんのシートがあるブックで作業したり、複数のブックを開いているときなどは、
となりのシートではなく、直前に参照していたシートに戻りたいという時がよくあります。
イメージとしては、Ctrl＋Tabで、以下の様な移動ができるショートカットが欲しい。といった感じです。





(図：必要とするショートカットによる移動イメージ)


Excelの標準機能には、残念ながらこういった機能はありません。

「Alt+Tabなどでファイルを選択→シートを選択する」ということをいちいちやるしかありません。

しかしそれは面倒なので、VBAでなんとかしてみました。

VBAで直前に参照していたブック.シートに戻る(参照履歴を保持する)

以下のサンプルを組み込むことで、上記で説明したCtrl＋Tabショートカットを実現できます。
※ブック・シートの参照履歴を保持し、直前に参照していたシートに戻ります。(アクティブにします)


参考：


VBA Help: How to run macro in active workbook (via SheetActivate) with code only in personal.xls


GPソフト Wiki - Excelのあれこれ 〜 マクロの自動ロード


エクセルExcel大事典 VBAマクロ イベントプロシージャ Open Target Cancel EnableEvents Volatile


Excel VBA 入門講座 ワークブックのイベントプロシージャ


WithEventsでイベントを拾う - EXCEL-LENCE web EnableEvents Volatile



[コードの記述箇所]

  (1) PERSONAL.XLSB＞Microsoft Excel Objects＞ThisWorkBook

  (2) PERSONAL.XLSB＞標準モジュール＞任意のモジュール（ただし他のモジュールとは独立したモジュール。以下例では「goBackSheet」モジュールとして追加しています。）





(図：コードの記述箇所)




以下、ソースです。



[サンプルソース(1)]※ThisWorkBookに記述

'PERSONAL.XLSB ThisWorkBook

'WithEventsにてApplicationオブジェクト(Excel全体を示すオブジェクト)に発生するイベントを拾える様にする
'PERSONAL.XLSBに記述することで、全てのExcelファイルに適用される。
Public WithEvents xlAPP As Application


'Excelブックが開いた時に自動実行する。
Private Sub Workbook_Open()
    

    'アプリケーションオブジェクトを取得
    Set xlAPP = Application
    

    '標準モジュールの初回呼出し
    '直接呼び出すとエラーになるため、実行時間をずらして呼び出す。
    Application.OnTime Now + TimeSerial(0, 0, 1), "appFirst"
    

End Sub


'シートがアクティブになった時に自動実行する。
'(ブック内)シート間での参照履歴を保持する。
Private Sub xlAPP_SheetActivate(ByVal Sh As Object)

    oldBook = nowBook
    oldSheet = nowSheet
    nowBook = ActiveWorkbook.Name
    nowSheet = Sh.Name
        

End Sub


'Excelウインドウがアクティブになった時に自動実行する。
'以下によりExcelファイルを跨いでも、参照履歴が保持される。
Private Sub xlAPP_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)

    oldBook = nowBook
    oldSheet = nowSheet
    nowBook = Wb.Name
    nowSheet = Wb.ActiveSheet.Name


End Sub


任意のブックではなく、Excel全般に適用したいため、PERSONAL.XLSBに記述します。

ThisWorkBookにはファイルオープン時やウインドウがアクティブになった時に自動実行させる、イベントプロシージャを利用したコードを記述しています。

その他の説明については、ソース内のコメントを参照してください。




[サンプルソース(2)]※標準モジュールに記述

'PERSONAL.XLSB 標準モジュール goBackSheet
'前に参照していたファイル.シートへ戻る(アクティブにする)


'マクロの実行メニューにPublicプロシージャが表示されないようにする。
Option Private Module


'参照履歴
Public oldBook  As String  '前に参照していたブック
Public oldSheet As String  '前に参照していたブック
Public nowBook  As String  '現在参照しているブック
Public nowSheet As String  '現在参照しているブック


'前に参照していたシートに戻る(Activeにする)マクロ
Public Sub oldsheet_act()


    'エラー発生した場合は無視する
    On Error Resume Next

    Workbooks(oldBook).Worksheets(oldSheet).Activate
    
End Sub

'Excel起動時に自動呼出しされるモジュール
Public Sub appFirst()

    'ファイル読込みに時間がかかるとエラーになるためスキップする
    On Error GoTo nextProc
    

    'ブック名・シート名を取得
    nowBook = ActiveWorkbook.Name
    nowSheet = ActiveSheet.Name
    
nextProc:
    

    'ショートカットキー（Ctrl+Tab)を設定。※同様にすれば、他のマクロもショートカット登録できます。
    Application.OnKey "^{TAB}", "OldSheet_act"   '…前に参照していたシートに戻るマクロを登録
    

End Sub


こちらは実際にシートを移動するためのコードを記述しています。

「oldsheet_act()」をショートカットキー（サンプルでは、Ctrl+Tab)で呼び出すことで、直前に参照していたファイルのシートへ移動できます。

ショートカットは、「appFirst()」をExcel起動時に呼出し、登録しています。

なお、既に他のマクロをCtrl+Tabで登録している場合は、上記ソースの「"^{TAB}"」を変更してください。

他のマクロも「appFirst()」へ記述すれば、ショートカットを登録できます。

その他の説明はソース内のコメントをご参照ください。



以上です。





2014.6.30 訂正

「appFirst()」に以下の処理を追加しました。


    'ファイル読込みに時間がかかるとエラーになるためスキップする
    On Error GoTo nextProc
    
    'ブック名・シート名を取得
    nowBook = ActiveWorkbook.Name
    nowSheet = ActiveSheet.Name
    
nextProc:


初回に開くファイルのサイズが大きい場合エラーになるため、対応しました。


VBAで特定のワークブック／ワークシート／オートシェイプ（図形）が存在するかチェックする

VBA EXCEL

VBAで以下を実現する方法について書きます。

１．特定のワークブックが存在するか（開いているか）チェックする

２．特定のワークシートが存在するかチェックする

３．特定のオートシェイプ（図形）が存在するかチェックする




参考

Workbook オブジェクト (Excel)


Worksheet オブジェクト (Excel)


Shape オブジェクト (Excel)

１．特定のワークブックが存在するか（開いているか）チェックする


[サンプルソース]

Public Function&Public Function checkExistBook(bookName As String) As Boolean
'------------------------------------------------------------------------------------------------------
' checkExistBook
' 対象のExcelブックを既に開いているかチェックする
'
' 引数１：bookName         ･･･ 対象のExcelブック名
' 戻り  ：boolean
'
'------------------------------------------------------------------------------------------------------
    
    Dim ret As Boolean
    ret = False
    
    Dim b As Workbook
    For Each b In Workbooks
        If b.Name = bookName Then
            ret = True
            GoTo endProc
        End If
    Next
    
endProc:
    
    checkExistBook = ret

End Function
Workbooksコレクション(Workbookオブジェクトの集合)をループし、対象の名前のブックが存在するか検索します。

ブック名称はWorkbookオブジェクトのnameプロパティから取得します。

再利用するためFunction化しています。


２．特定のワークシートが存在するかチェックする


[サンプルソース]

Public Function checkExistSheet(sheetName As String) As Boolean
'------------------------------------------------------------------------------------------------------
' checkExistSheet
' 対象のワークシートがアクティブなブック内に存在するかチェックする
'
' 引数１：sheetName         ･･･ 対象のExcelワークシート名
' 戻り  ：boolean
'
'------------------------------------------------------------------------------------------------------

    Dim ret As Boolean
    ret = False
    
    Dim s As Worksheet
    For Each s In Worksheets
        If s.Name = sheetName Then
            ret = True
            GoTo endProc
        End If
    Next
    
endProc:

    checkExistSheet = ret
    
End Function
今度は、Worksheetsコレクション(Worksheetオブジェクトの集合)をループし、対象の名前のシートが存在するか検索します。

シート名称はWorksheetオブジェクトのnameプロパティから取得します。

これもFunction化していますが、第2引数には、オプションでブック名を指定できるようにしています。

アクティブなブックを対象としたい場合は、引数なしにできます。

ただし任意のブック名を指定する場合、指定したブックが存在するかはチェックしないので、項番１のFunctionを呼び出すなどしてチェックが必要です。


特定のオートシェイプ（図形）が存在するかチェックする


[サンプルソース]

Public Function checkExistShape(ByVal shapeName As String, Optional ByVal sheetName = "", Optional ByVal bookName = "") As Boolean
'------------------------------------------------------------------------------------------------------
' checkExistShape
' オートシェイプが存在するかチェックする
'
' 引数１：shapeName         ･･･ 対象のオートシェイプ名
' 引数２：sheetName         ･･･ シート名（省略時はActiveシート)
' 引数３：bookName          ･･･ ブック名（省略時はActiveブック)
' 戻り  ：boolean
'
'------------------------------------------------------------------------------------------------------
    Dim sName As String 'シート名
    Dim bName As String 'ブック名
    
    'シート名を設定
    If sheetName = "" Then
        sName = ActiveSheet.Name
        
    Else
        sName = sheetName
        
    End If
    
    'ブック名を設定
    If bookName = "" Then
        bName = ActiveWorkbook.Name
        
    Else
        bName = bookName
        
    End If
    
    Dim ret As Boolean
    Dim s As Shape
    For Each s In Workbooks(bName).Worksheets(sName).Shapes
        If s.Name = shapeName Then
            ret = True
            GoTo endProc
        End If
    Next
    
endProc:

    checkExistShape = ret
    
End Function
ここまでくれば説明もいらないと思いますが、

Shapesコレクション(Shapeオブジェクトの集合)をループし、対象の名前のオートシェイプが存在するか検索します。

オートシェイプの名称はShapeオブジェクトのnameプロパティから取得します。

同様にFunction化しており、第2・第3引数で、シート名・ブック名を指定できます(省略可)。

任意のシート名・ブック名を指定する場合は、存在するシート・ブックであるか、あらかじめチェックしておく必要があります。


テストしてみる

Functionの呼出しだけですが、サンプルを用意しました。

標準モジュールに項番１〜３のFunctionと合わせて記述して、実行してください。

なお、エラー処理については省略しています。



[サンプルソース]

Sub test()

    

    Dim tBook As String

    Dim tSheet As String

    Dim tShape As String

    

    tBook = "Book1"

    tSheet = "Sheet1"

    tShape = "図形1"

    

    If checkExistBook(tBook) Then

        MsgBox (tBook + "がいました")

    End If

    If checkExistSheet(tSheet) Then

        MsgBox (tSheet + "がいました")

    End If

    If checkExistSheet(tSheet, tBook) Then

        MsgBox (tBook + "に" + tSheet + "がいました")

    End If

    If checkExistShape(tShape) Then

        MsgBox (tShape + "がいました")

    End If

    If checkExistShape(tShape, tSheet) Then

        MsgBox (tSheet + "に" + tShape + "がいました")

    End If

    If checkExistShape(tShape, tSheet, tBook) Then

        MsgBox (tBook + "の" + tSheet + "に" + tShape + "がいました")

    End If

    

End Sub


以上です。




2014.7.2 追記

対象を発見した時点でループを抜ける処理が漏れていたため、追加しました。


            ret = True
            GoTo endProc  '←
        End If
    Next
    
endProc:  '←
    checkExistBook = ret

VBAで任意フォルダのファイル一覧を取得する(Dir関数の使用)

VBA EXCEL


VBAで任意フォルダのファイル一覧を取得する方法について書きます。

マクロから外部ファイルを読込む様な処理で、

(任意)フォルダ直下の全ファイルについて処理したい場合に有効です。


VBAで任意フォルダのファイル一覧を取得する(Dir関数の使用)



参考
Dir関数 microsoft
VBA応用(フォルダ内のファイル一覧の取得)



[ソース]

Public Function getFileList(ByVal folderPass As String, Optional ByVal onlyXLS = 0) As String()
'------------------------------------------------------------------------------------------------------
' getFileList
' 指定したフォルダのファイル一覧を取得する
'
' 引数１：folderPass         ･･･ フォルダパス
' 引数２：onlyXLS            ･･･ 「.xls」を含むファイル名のみ取得するか否か(デフォルト：0(全てのファイル))
'
' 戻り：String()             ･･･ ファイル一覧
'
' 使用注：フォルダパスの整合性確認は参照元で実装してください。（If Dir(folderPass, vbDirectory) = "" Then）
'------------------------------------------------------------------------------------------------------
    
    Const xlsKey = ".xls"     'Excelファイル判定キー
    Const cnsDIR = "\*.*"
    Dim fileName As String
    
    Dim ret() As String   '返却用配列
    Dim i As Long         '返却用配列 カウンタ
    
    ' 先頭のファイル名取得
    fileName = Dir(folderPass & cnsDIR, vbNormal)
    
    ' 指定フォルダの全Excelワークブックについて繰り返す
    Do While fileName <> ""
        
        '「.xls」を含むファイル名のみ取得する場合
        If onlyXLS Then
        
            '「.xls」を含まないファイル名は除外する
            If InStr(fileName, xlsKey) = 0 Then
            
                GoTo nextDO
                
            End If
            
        End If
        
        'ファイル名を返却用配列に格納
        ReDim Preserve ret(i) As String
        ret(i) = fileName
        i = i + 1
        
nextDO:

        ' 次のファイル名を参照
        fileName = Dir()
    
    Loop
    
    getFileList = ret

End Function

Dir関数の仕様ですが、

1度目のDir呼出しは、第1引数にフォルダパスを設定します。

　→先頭のファイル名が返却されます。

　　※第2引数はファイル種別です。なおvbNormalは規定値なので省略可です。
2度目以降(Doループ処理内)のDir呼出しは引数なしにします。

　→ファイルが無くなった時点で空値が返却される様です。



今までマクロを組む時は、このDir()関数の呼出しループ内に処理を記載していたのですが、

コードの可読性UP＋再利用の為にFunction化しました。

呼出し元で結局ファイルリスト分ループ処理を実装する必要があるため、処理は増えてしまいます。



フォルダパスの整合性については、参照元で実装する必要があります。

Function内でエラー判定してしまうと、Boolean等の返却が必要になり、あまりきれいにできないかと思った為です。



テストしてみる

以下は、テスト用のモジュールです。


[ソース]

Public Sub testGetFileList()
    
    'メッセージ
    Dim msg As String
    
    'フォルダパス(サンプル)
    Dim folderPass As String
    folderPass = "C:\wk\vba\sampleDir"
    
    'ファイルリスト
    Dim list() As String
    
    'フォルダパスの整合性確認
    If Dir(folderPass, vbDirectory) = "" Then
        msg = MsgBox("指定したフォルダは存在しません", vbOKOnly, "getFileList()のテスト")
        Exit Sub
        
    'フォルダパスが正しい場合
    Else
        Call addMsg(msg, "指定したフォルダ:")
        Call addMsg(msg, folderPass)
        Call addMsg(msg)
        Call addMsg(msg, "ファイル一覧")
        Call addMsg(msg, "------------------------------")
        
        'ファイルリストの取得
        list = getFileList(folderPass)
        
        Dim i As Long 'カウンタ
        
        'ファイルリストの数分ループ
        For i = 0 To UBound(list, 1)
            Call addMsg(msg, list(i))
        Next i
        
        Call addMsg(msg, "------------------------------")
        
    End If
    
    msg = MsgBox(msg, vbOKOnly, "getFileList()のテスト")
    
End Sub
Private Sub addMsg(msg As String, Optional addMsg = "")
    msg = msg + addMsg + vbCrLf
End Sub



サンプルフォルダを作成して、テストプロシージャを実行してみます。






（testGetFileList()を実行）


↓





ファイル一覧が取得できました。サブフォルダは取得されませんね。

フォルダパスが誤っていた場合は、以下の様にエラーとなります。




（フォルダパスが誤っていた場合：エラー）


ちなみに、今回のFunctionには第2引数に「onlyXLS」として、「.xls」を含むファイルのみ抽出するか選択できるようにしてみました。



[onlyXLSを使用する場合のソース]

        'ファイルリストの取得
        list = getFileList(folderPass, 1)


この状態でテストモジュール(testGetFileList())を実行した結果は、以下の通りです。





（testGetFileList()の実行結果）



以上です。

VBAで（オートシェイプ（図形）を含めた）シート上の全ての文言を取得する

VBA EXCEL


VBAでワークシート上にある全ての文言を取得する方法について書きます。

１．オートシェイプ（図形）の文言を取得する



セル内の文言はRange("A1").Valueなどで簡単に取得できますが、

以下の様なオートシェイプ（図形）に含まれる文言は

ShapesオブジェクトのTextFrameプロパティから取得する必要があります。




Shepes.TextFrameプロパティ



[サンプル]

 以下のサンプルでは、アクティブシート上にある1番目の図形から、レイアウト枠内のテキスト表示します。


MsgBox ActiveSheet.Shapes(1).TextFrame.Characters.text




（実行例）


 Shapes()の引数は図形の名称でも構いません。

 直線など、図形にレイアウト枠がない場合、エラーとなります。

２．シート上にある全てのオートシェイプ（図形）から文言を取得する



以上の内容をもとに、シート上にある全てのオートシェイプから文言を取得するFunctionを作成しました。



[ソース]

Public Function getShapesProperty(bookName As String, sheetName As String) As String()

'------------------------------------------

'getShapesText

'対象シート上にあるオブジェクトのプロパティを取得する

'引数１：bookName as String   対象ブック名

'引数２：sheetName as String   対象シート名

'戻り：getShapesProperty as string(2,n)

'          (0,n) .type

'          (1,n) .name

'          (2,n) .TextFrame.Characters.text

'          (3,n) .Left

'          (4,n) .Top

'          (5,n) .Width

'          (6,n) .Height

'          (7,n) .TopLeftCell.Address(False, False)

'          (8,n) .BottomRightCell.Address(False, False)

'

'------------------------------------------

    Dim ret() As String

    Dim i As Long

    Dim obj As Object

    

    For Each obj In Workbooks(bookName).Sheets(sheetName).Shapes

        ReDim Preserve ret(8, i) As String

        ret(0, i) = CStr(obj.Type)

        ret(1, i) = CStr(obj.Name)

                

        'TextFrameプロパティが使用できない(レイアウト枠がない)オブジェクトは除外

        On Error Resume Next

        ret(2, i) = obj.TextFrame.Characters.text

        

        ret(3, i) = CStr(obj.Left)

        ret(4, i) = CStr(obj.Top)

        ret(5, i) = CStr(obj.Width)

        ret(6, i) = CStr(obj.Height)

        ret(7, i) = CStr(obj.TopLeftCell.Address(False, False))

        ret(8, i) = CStr(obj.BottomRightCell.Address(False, False))

        

        i = i + 1



    Next

    

    getShapesProperty = ret

    

End Function
引数にはブック名・シート名を指定します。

文言のほか、図形の幅などの情報も持たせたString配列を返却します。

レイアウト枠がない図形は、エラーをスキップして処理しています(On Error Resume Next)。

（もう少しきれいな方法があれば良かったんですが。。。）



２．１．テストしてみる（オートシェイプの文言取得）

以下のソースを実行して、テストしてみます。


[テストコード]



Sub test_getShepesProperty()

    

    Dim str() As String

    str = getShapesProperty(ThisWorkbook.name, ActiveSheet.name)

    

    Dim msg As String

    Call addMsg(msg, "オートシェイプのプロパティを取得")

    

    Dim i As Long

    For i = 0 To UBound(str, 2)

        Call addMsg(msg, "図形：" + CStr(i + 1))

        Call addMsg(msg, "図形種別(.Type)：" + str(0, i))

        Call addMsg(msg, "名称(.Name)：" + str(1, i))

        Call addMsg(msg, "文言(.TextFrame.Characters.text)：" + str(2, i))

        Call addMsg(msg, "左位置(.Left)：" + str(3, i))

        Call addMsg(msg, "上位置(.Top)：" + str(4, i))

        Call addMsg(msg, "幅(.Width)：" + str(5, i))

        Call addMsg(msg, "高さ(.Height)：" + str(6, i))

        Call addMsg(msg, "図形左上のセル(.TopLeftCell.Address)：" + str(7, i))

        Call addMsg(msg, "図形右下のセル(.BottomRightCell.Address)：" + str(8, i))

        Call addMsg(msg)

    Next i

    

    MsgBox msg

    

End Sub



Sub addMsg(msg As String, Optional addMsg = "")

    msg = msg + addMsg + vbCrLf

End Sub




以下はテスト用のシートです。





（test_getShepesProperty()を実行）

↓







全てのオートシェイプから、文言を取得することができました。

３．シート上の全てのセル内の文言を取得する



一応、セル内の文言を取得するFunctionも作成しました。



[ソース]


Function getTextOnCell(bookName As String, sheetName As String) As String()

'------------------------------------------

'getTextOnCell

'対象シート上にあるセル内の文言を取得する

'

'戻り：getTextOnCell as string(2,n)

'          (0,n) 行

'          (1,n) 列

'          (2,n) 文言

'

'------------------------------------------

    Workbooks(bookName).Sheets(sheetName).Activate

    

    Dim ret() As String

    Dim r As Long  'ret()用カウンタ

    

    Dim sRow As Long

    Dim sCol As Long

    Dim lRow As Long

    Dim lCol As Long

    sRow = 1

    sCol = 1

    Call getRange(sheetName, lRow, lCol)

    

    'データ

    Dim i As Long

    Dim j As Long

    Dim str As String

    For i = sRow To lRow

        For j = sCol To lCol

            str = Workbooks(bookName).Sheets(sheetName).Cells(i, j).Value

            If str <> "" Then

                ReDim Preserve ret(2, r) As String

                ret(0, r) = CStr(i)

                ret(1, r) = CStr(j)

                ret(2, r) = str

                r = r + 1

            Else

                '処理なし

            End If

        Next j

    Next i

    

    getTextOnCell = ret

    

End Function

Sub getRange(sheetName As String, lRow As Long, lCol As Long)

'------------------------------------------------------------------------------------

'getRange

'シート最終行列の設定

'引数１：sheetName・・・・・・シート名

'引数２：lRow ・・・・・・・・最終行

'引数３：lCol ・・・・・・・・最終列

'

'------------------------------------------------------------------------------------

    s = Sheets(sheetName).UsedRange.Address              '有効レンジ範囲

    lRow = Range(s).Rows(Range(s).Rows.count).Row               '最終行

    lCol = Range(s).Columns(Range(s).Columns.count).Column      '最終列



End Sub


引数にはブック名、シート名を指定します。

セル(1, 1)から最終セルまでの文言を取得し、String配列で返却します。



３．２．テストしてみる（セル内の文言取得）



以下のテストコードを実行し、テストしてみます。


Sub test_getTextOnCell()

    

    Dim str() As String

    str = getTextOnCell(ThisWorkbook.name, ActiveSheet.name)

    

    Dim msg As String

    Call addMsg(msg, "セル内の文言一覧")

    Call addMsg(msg)

    

    Dim i As Long

    For i = 0 To UBound(str, 2)

        Call addMsg(msg, "行：" + str(0, i))

        Call addMsg(msg, "列：" + str(1, i))

        Call addMsg(msg, "文言：" + str(2, i))

        Call addMsg(msg)

    Next i

    

    MsgBox msg

    

End Sub

Sub addMsg(msg As String, Optional addMsg = "")

    msg = msg + addMsg + vbCrLf

End Sub


以下はテスト用シートです。



(test_getTextOnCell()を実行)

↓




以上の通り、セル内の文言を取得できました。

今回作成した2つのFunctionで、シート上の全ての文言を取得できます。

VBAでExcelにワークシートを追加する

EXCEL VBA


ググればいくらでもでてくると思いますが、VBAでExcelにワークシートを追加する方法です。

VBAでExcelにワークシートを追加する（Worksheets.Add）



「Worksheets.Add」の処理でワークシートを追加します。

他のマクロから呼び出して使えるように、Functionにしてみました。



[ソース]

Public Function addWorkSheet(sheetName As String) As String
'------------------------------------------
'addWorkSheet
'引数で指定したシート名でワークシートを追加する。
'
'戻り：addWorkSheet as String
'       OK or NG
'
'------------------------------------------
    Dim obj As Worksheet
    Dim sheet As Worksheet
    For Each obj In Worksheets
        If sheetName = obj.Name Then
            addWorkSheet = "NG"
            Exit Function
        End If
    Next
    Set sheet = Worksheets.Add
    sheet.Name = sheetName
    addWorkSheet = "OK"
    
End Function
引数に指定したシート名で、Excelにシートを追加します。

同一名のシートがすでに存在する場合は、シートを追加しません。

実行結果はStringでOK/NGを返却します。（いけてない・・・）

VBAでシートのデータがある最終行列を取得する

VBA EXCEL


マクロを作成する際に、シート上の（データがある）最終行列を取得したくなる時があります。（ループ処理したり）

ということで以下のプロシージャを作成。

データがある最終行列を取得する

[ソース]

Private Sub getRange(sheetName As String, lRow As Long, lCol As Long)
'------------------------------------------------------------------------------------
'getRange
'シート最終行列の設定
'引数１：sheetName・・・・・・シート名
'引数２：lRow ・・・・・・・・最終行
'引数３：lCol ・・・・・・・・最終列
'
'------------------------------------------------------------------------------------
    s = Sheets(sheetName).UsedRange.Address                           '有効レンジ範囲
    lRow = Range(s).Rows(Range(s).Rows.count).Row               '最終行
    lCol = Range(s).Columns(Range(s).Columns.count).Column      '最終列

End Sub
わずか3行でした。

参照元のマクロと同じモジュール内に記述する想定で、privateになっています。

別モジュールから参照する場合はpublicにしないといけませんね。

テストしてみる

[ソース]

Sub testGetRange()
'getRange()のテスト
    
    Dim sheetName As String      '対象シート
    sheetName = ActiveSheet.name 'アクティブシートを設定
    
    '実際の使用を想定して、一応開始行列も宣言
    Dim sRow As String  '開始行
    Dim sCol As String  '開始列
    sRow = 1
    sCol = 1
    
    '最終行列の変数を宣言
    Dim lRow As Long  '終了行
    Dim lCol As Long  '終了列
    
    '最終行列を設定する
    Call getRange(sheetName, lRow, lCol)
    
    
    Dim msg As String
    msg = "シート上の" + vbCrLf
    msg = msg + "最終行：" + CStr(lRow) + vbCrLf
    msg = msg + "最終列：" + CStr(lCol) + vbCrLf
    MsgBox msg
    
End Sub


[実行してみる]




(testGetRange()を実行)

↓




こんな感じになりました。

VBAでテキストファイルを読み込み／書き込み

EXCEL Microsoft ADO UTF-8 Shift-JIS VBA


VBAでテキストファイルを読んだり書いたりするために、マクロを作成。



かなり参考にさせていただいたサイト

  [Excel]Excel VBAでUTF-8のテキストファイルを扱う(ADODB.Stream)Add Star

１．テキストを読み込む



テキストファイルをStringまたはString配列で読み込みます。

Private Function readText(fullFileName As String, Optional outputType = 1, Optional charcode = 0)
'-----------------------------------------------
' readText
' 引数の情報でテキストファイルを読み込む
' 使用注：VBAでMicrosoftADOの参照設定が必要
'
' 引数１：fullFileName String    ファイルパス
' 引数２：outputType String     出力タイプ(省略可、デフォルト1)
'                                 0:String型
'                                 1:String()型
' 引数３：charcode long         文字コード(省略可、デフォルト0)
'                                 0:Shift-JIS
'                                 1:UTF-8
'
'-----------------------------------------------

    Dim str As String
    Dim strArr() As String
    ReDim Preserve strArr(0) As String

    'Streamオブジェクト作成
    Dim fObj As Object
    Set fObj = CreateObject("ADODB.Stream")

    'オブジェクトに保存するデータの種類を文字列型に指定する
    fObj.Type = adTypeText

    '文字列型のオブジェクトの文字コードを指定する
    If charcode = 0 Then
        fObj.charset = "Shift-JIS"
    Else
        fObj.charset = "UTF-8"
    End If

    'オブジェクトのインスタンスを作成
    fObj.Open

    'ファイルからデータを読み込む
    fObj.LoadFromFile (fullFileName)

    If outputType = 1 Then
        '最終行までループする
        Do While Not fObj.EOS
            '次の行を読み取る
            strArr(UBound(strArr)) = fObj.readText(adReadLine)
            ReDim Preserve strArr(UBound(strArr) + 1) As String
        Loop

    Else
        str = fObj.readText(adReadAll)
    End If

    'オブジェクトを閉じる
    fObj.Close

    'メモリからオブジェクトを削除する
    Set fObj = Nothing

    If outputType = 1 Then
        readText = strArr
    Else
        readText = str
    End If

End Function


第1引数にフルパスのファイル名

第2引数には返却する型

第3引数にはファイルの文字コードを指定できます。(Shit-JIS／UTF-8)

行単位で処理したい時はString()で返却する様にしますね。

２．テキストを書き込む（文字列型）



Stringのデータをテキストファイルに書き込みます。

Private Sub writeText(fullFileName As String, text As String, Optional overWriteClass = 1, Optional charcode = 0)
'-----------------------------------------------
' writeText
' 引数の情報でテキストファイルへ書き込む
' 使用注：VBAでMicrosoftADOの参照設定が必要
'
' 引数１：fullFileName String    ファイルパス
' 引数２：text String            書き込みテキスト（改行可）
' 引数３：overWriteClass long     上書き区分(省略可、デフォルト1)
'                                 0:上書きしない
'                                 1:上書きする(ファイルない場合新規作成）
'                                 2:追記する(ファイルない場合新規作成）
' 引数４：charcode long         文字コード(省略可、デフォルト0)
'                                 0:Shift-JIS
'                                 1:UTF-8
'
'-----------------------------------------------

    Dim wText As String

    'Streamオブジェクト作成
    Dim fObj As Object
    Set fObj = CreateObject("ADODB.Stream")

    'オブジェクトに保存するデータの種類を文字列型に指定する
    fObj.Type = adTypeText

    '文字列型のオブジェクトの文字コードを指定する
    If charcode = 0 Then
        fObj.charset = "Shift-JIS"
    Else
        fObj.charset = "UTF-8"
    End If

    '出力タイプ2:追記の場合、既存テキストを読み込む
    If overWriteClass = 2 Then
        'ファイルない場合、エラーを無視する
        On Error GoTo Err1
        wText = readText(fullFileName, 0, charcode) + vbCrLf + text

    Else

Err1:
        wText = text
    End If

    'オブジェクトのインスタンスを作成
    fObj.Open

    'テキストをオブジェクトに書き込む
    fObj.writeText wText, adWriteAll

    'オブジェクトの内容をファイルに保存
    If overWriteClass = 1 Or overWriteClass = 2 Then
        fObj.SaveToFile (fullFileName), adSaveCreateOverWrite

    Else
        fObj.SaveToFile (fullFileName), adSaveCreateNotExist

    End If

    'オブジェクトを閉じる
    fObj.Close

    'メモリからオブジェクトを削除する
    Set fObj = Nothing

End Sub

３．テキストを書き込む（文字配列型）



項番２のwriteText()を使用して

String配列のデータをテキストファイルに書き込みます。

Private Sub writeTextByStrArr(fullFileName As String, text() As String, Optional overWriteClass = 1, Optional charcode = 0)
'-----------------------------------------------
' writeTextByStrArr
' writeText()を使用してStrArr型の文字列をテキストファイルへ書き込む
' 使用注：VBAでMicrosoftADOの参照設定が必要
'
' 引数１：fullFileName String    ファイルパス
' 引数２：text() String            書き込みテキスト
' 引数３：overWriteClass long     上書き区分(省略可、デフォルト1)
'                                 0:上書きしない
'                                 1:上書きする(ファイルない場合新規作成）
'                                 2:追記する(ファイルない場合新規作成）
' 引数４：charcode long         文字コード(省略可、デフォルト0)
'                                 0:Shift-JIS
'                                 1:UTF-8
'
'-----------------------------------------------
    Dim wStr As String
    Dim x As Long
    
    For x = 0 To UBound(text) - 1
        wStr = wStr + text(x) + vbCrLf
    Next x
    
    '最終行は改行追加しない
    wStr = wStr + text(x)
    
    Call writeText(fullFileName, wStr, overWriteClass, charcode)
    
End Sub

MicrosoftADOの参照設定



今回作成したマクロではVBAで[Microsoft ActiveX Data Objects]の参照設定が必要。

以下の通り。



2014.6.13 訂正

上記のwriteTextByStrArr()に誤りがあり、
以下のコードを削除しました。
参照していた方、申し訳ありません。


＞    '最終行は改行追加しない
＞    x = x + 1
＞    wStr = wStr + text(x)