禁断の技、ユーザー定義関数で他のセルにデータを入れる方法

投稿日: 2024年9月26日 作成者: ooooo

関数のコードの中で他のセルにデータを入れることはできません。セルにデータを入れるSubプロシージャを作り、関数からそのSubプロシージャを呼び出しも禁止されてます。

これは、再計算の繰り返しにならないようにするためだそうです。

でも対応策はあります。

イベントを使います。関数が計算して戻り値を更新するとWorksheet_Changeイベントが発生します。このSubプロシージャを使ってセルにデータを入れることは可能です。

Sheet1のコード、イベントのコードです。

コピーできるようにコードを貼り付けておきます。

Private Sub Worksheet_Change(ByVal Target As Range)
    If 1 = gaaa Then
        gaaa = 0
        Excel.Application.EnableEvents = False '次行でWorksheet_Changeイベントが何度も発生しないようにする
        grInput.Value = Now '変化したことが分かるように時間を入れる
        Excel.Application.EnableEvents = True '解除
    End If
End Sub

以下は関数aaaとグローバル変数gaaaとgrInputを定義してます。標準モジュールを追加して書きます。

Public gaaa, grInput

Function aaa(r As Range, rInput As Range) 'rの範囲が変化したらこの関数は実行します
    ' 現在のセルが対象範囲内かを確認
    If Not Intersect(ActiveCell, r) Is Nothing Then
        ' 対象範囲内のセルの場合の処理
        gaaa = 1
        Set grInput = rInput
    End If
End Function

G6に=aaa(B1:F5,I1)を入れます。B1からF5の範囲にデータを入れるとI1の時間が変わります。I1の書式は秒まで見えるようにしておきましょう。変化がわかりませんので。

何かの加減でChangeイベントプロシージャが実行しない場合は、イベントが無効になっている可能性があります。以下のコードをイミディエイトウィンドウに貼り付けて実行してください。貼り付けた位置にカーソルを移動してエンターで実行します。

カテゴリー: 14 イベントの使い方 ＜VBA＞ | コメントする

Excelフォームを使ってエクスプローラーが開いているフォルダ下全部の指定した拡張子のファイルを順に開くマクロ

投稿日: 2024年9月21日 作成者: ooooo

前にアップしたExcelファイルのあるフォルダ下全部のExcelファイルを順に開いて閉じるマクロ。

これにフォームを追加して、特定のフォルダを指定してそれ以下全部検索してファイルを開くマクロに修正します。

順に、

Windowsエクスプローラーで開いているフォルダを取り出す関数GetCurrentFolderToExplorer。複数のエクスプローラーが起動している場合は最初に見つかったエクスプローラーです。戻り値がフォルダのパスです、失敗したらFalseの値です。

Function GetCurrentFolderToExplorer() As String
    Dim shellApp As Object
    Dim windows As Object
    Dim explorer As Object
    Dim window As Object
    
    ' Create Shell object
    Set shellApp = CreateObject("Shell.Application")
    
    ' Get all open windows
    Set windows = shellApp.windows
    
    ' Loop through all open windows
    For Each window In windows
        ' Check if the window is an Explorer window (not Internet Explorer or other types)
        If InStr(1, window.FullName, "explorer.exe", vbTextCompare) > 0 Then
            ' Get the path of the folder
            GetCurrentFolderToExplorer = window.document.folder.Self.Path
            
            Exit Function
        End If
    Next window
    GetCurrentFolderToExplorer = ""
    
End Function

Excelフォーム/UserFormにコンボボックスとコマンドボタンを貼り付けます。

Option Explicit

Private Sub CommandButton1_Click()
    Dim ss As String
    ss = GetCurrentFolderToExplorer　'開いているエクスプローラーのパスをssに入れる
    If "" <> ss Then
        OpenAndCloseAllXLSXFiles ss, Me.ComboBox1.Value
    Else
        MsgBox "エクスプローラーが起動してません"
    End If
End Sub

Private Sub UserForm_Initialize()
    ComboBox1.AddItem ".xlsx"
    ComboBox1.AddItem ".xlsm"
    Me.ComboBox1.Value = Me.ComboBox1.List(0)
End Sub
Sub OpenAndCloseAllXLSXFiles()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object

    ' フォルダのパスを指定します
    folderPath = Excel.ThisWorkbook.Path

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath)
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    ' フォルダ内のすべてのファイルを処理
    For Each file In folder.Files
        VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
        If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
            If Right(file.Name, 5) = ".xlsx" Then
                ' xlsxファイルを開く
                On Error Resume Next ' エラーを無視する
                Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                Set wb = Workbooks.Open(file.Path)
                If Not wb Is Nothing Then
                    Application.Wait Now + TimeValue("0:0:1")'1秒待つ
                    ' ファイルを閉じる
                    wb.Close False
                    Set wb = Nothing
                End If
                On Error GoTo 0 ' エラーハンドリングをリセット
            End If
        End If
    Next file

    ' サブフォルダを再帰的に処理
    For Each subFolder In folder.SubFolders
        ProcessFolder subFolder
    Next subFolder
End Sub

前のSubプロシージャOpenAndCloseAllXLSXFilesに引数folderPathとmyFileを追加、myFile は拡張子を入れます。SubプロシージャProcessFolderの方も引数myFileを追加してます。

Sub OpenAndCloseAllXLSXFiles(folderPath As String, myFile As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath), myFile
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object, myFile As String)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    Debug.Print folder
    If Dir(folder, vbDirectory) <> "" Then  'フォルダがあるか確認ァイルを処理
　　　　' フォルダ内のすべてのファイルを処理
        For Each file In folder.Files　　
            VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
            If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
                If Right(file.Name, Len(myFile)) = myFile Then
                    ' xlsxファイルを開く
                    On Error Resume Next ' エラーを無視する
                    Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                    Set wb = Workbooks.Open(file.Path)
                    If Not wb Is Nothing Then
                        Application.Wait Now + TimeValue("0:0:1") '1秒待つ
                        ' ファイルを閉じる
                        wb.Close False
                        Set wb = Nothing
                    End If
                    On Error GoTo 0 ' エラーハンドリングをリセット
                End If
            End If
        Next file
    ' サブフォルダを再帰的に処理
        For Each subFolder In folder.SubFolders
            ProcessFolder subFolder, myFile
        Next subFolder
    End If
End Sub
カテゴリー: VBA, 13 ファイル処理、メモ帳とのデータ処理 | コメントする

Excelファイルがあるフォルダとその下の全xlsxファイルを順に開いて閉じる

投稿日: 2024年9月18日 作成者: ooooo

開いたExcelファイルは1秒後に閉じます。繰り返し処理の間、止めることもできないのでDoEventsでを入れてます。

ディスクトップにExcelファイルを作ってVBEを開いて標準モジュールに貼り付け実行するとディスクトップ以下のxlsx拡張子のファイルを全部開き閉じます。

Sub OpenAndCloseAllXLSXFiles()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object

    ' フォルダのパスを指定します
    folderPath = Excel.ThisWorkbook.Path

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath)
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    Debug.Print folder
    If "" <> VBA.Dir(folder, vbDirectory) Then'フォルダがあるか確認
        ' フォルダ内のすべてのファイルを処理
        For Each file In folder.Files
            VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
            If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
                If Right(file.Name, 5) = ".xlsx" Then
                    ' xlsxファイルを開く
                    On Error Resume Next ' エラーを無視する
                    Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                    Set wb = Workbooks.Open(file.Path)
                    If Not wb Is Nothing Then
                        Application.Wait Now + TimeValue("0:0:1") '1秒待つ
                        ' ファイルを閉じる
                        wb.Close False
                        Set wb = Nothing
                    End If
                    On Error GoTo 0 ' エラーハンドリングをリセット
                End If
            End If
        Next file
    
        ' サブフォルダを再帰的に処理
        For Each subFolder In folder.SubFolders
            ProcessFolder subFolder
        Next subFolder
    End If
End Sub

これにフォームを追加して、特定のフォルダを指定してそれ以下全部検索してファイルを開くマクロに修正します。

順に、

Windowsエクスプローラーで開いているフォルダを取り出す関数GetCurrentFolderToExplorer。複数のエクスプローラーが起動している場合は最初に見つかったエクスプローラーです。戻り値がフォルダのパスです、失敗したらFalseの値です。

Function GetCurrentFolderToExplorer() As String
    Dim shellApp As Object
    Dim windows As Object
    Dim explorer As Object
    Dim window As Object
    
    ' Create Shell object
    Set shellApp = CreateObject("Shell.Application")
    
    ' Get all open windows
    Set windows = shellApp.windows
    
    ' Loop through all open windows
    For Each window In windows
        ' Check if the window is an Explorer window (not Internet Explorer or other types)
        If InStr(1, window.FullName, "explorer.exe", vbTextCompare) > 0 Then
            ' Get the path of the folder
            GetCurrentFolderToExplorer = window.document.folder.Self.Path
            
            Exit Function
        End If
    Next window
    GetCurrentFolderToExplorer = ""
    
End Function

Excelフォーム/UserFormにコンボボックスとコマンドボタンを貼り付けます。

Option Explicit

Private Sub CommandButton1_Click()
    Dim ss As String
    ss = GetCurrentFolderToExplorer　'開いているエクスプローラーのパスをssに入れる
    If "" <> ss Then
        OpenAndCloseAllXLSXFiles ss, Me.ComboBox1.Value
    Else
        MsgBox "エクスプローラーが起動してません"
    End If
End Sub

Private Sub UserForm_Initialize()
    ComboBox1.AddItem ".xlsx"
    ComboBox1.AddItem ".xlsm"
    Me.ComboBox1.Value = Me.ComboBox1.List(0)
End Sub
Sub OpenAndCloseAllXLSXFiles()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object

    ' フォルダのパスを指定します
    folderPath = Excel.ThisWorkbook.Path

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath)
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    ' フォルダ内のすべてのファイルを処理
    For Each file In folder.Files
        VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
        If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
            If Right(file.Name, 5) = ".xlsx" Then
                ' xlsxファイルを開く
                On Error Resume Next ' エラーを無視する
                Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                Set wb = Workbooks.Open(file.Path)
                If Not wb Is Nothing Then
                    Application.Wait Now + TimeValue("0:0:1")'1秒待つ
                    ' ファイルを閉じる
                    wb.Close False
                    Set wb = Nothing
                End If
                On Error GoTo 0 ' エラーハンドリングをリセット
            End If
        End If
    Next file

    ' サブフォルダを再帰的に処理
    For Each subFolder In folder.SubFolders
        ProcessFolder subFolder
    Next subFolder
End Sub

前のSubプロシージャOpenAndCloseAllXLSXFilesに引数folderPathとmyFileを追加、myFile は拡張子を入れます。SubプロシージャProcessFolderの方も引数myFileを追加してます。

Sub OpenAndCloseAllXLSXFiles(folderPath As String, myFile As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath), myFile
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object, myFile As String)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    Debug.Print folder
    If Dir(folder, vbDirectory) <> "" Then  'フォルダがあるか確認ァイルを処理
　　　　' フォルダ内のすべてのファイルを処理
        For Each file In folder.Files　　
            VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
            If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
                If Right(file.Name, Len(myFile)) = myFile Then
                    ' xlsxファイルを開く
                    On Error Resume Next ' エラーを無視する
                    Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                    Set wb = Workbooks.Open(file.Path)
                    If Not wb Is Nothing Then
                        Application.Wait Now + TimeValue("0:0:1") '1秒待つ
                        ' ファイルを閉じる
                        wb.Close False
                        Set wb = Nothing
                    End If
                    On Error GoTo 0 ' エラーハンドリングをリセット
                End If
            End If
        Next file
    ' サブフォルダを再帰的に処理
        For Each subFolder In folder.SubFolders
            ProcessFolder subFolder, myFile
        Next subFolder
    End If
End Sub
カテゴリー: 13 ファイル処理、メモ帳とのデータ処理 | コメントする

プロジェクトまたはライブラリが見つかりません。というコンパイルエラー

投稿日: 2021年2月16日 作成者: ooooo

VBAコードのRangeの位置でエラーになる。

VBAのツールの参照設定で参照できないファイルがあるはず。私の場合、Rangeで名前の参照ができないエラーで遭遇する。Rangeは関係ない。参照設定を確認しましょう。

カテゴリー: とりあえず | コメントする

Exclマクロ特有？引数なしのプロシージャ

投稿日: 2020年5月18日 作成者: ooooo

何それ？

文中に？があるし、変ですが。

「引数なしのプロシージャ」について語りたい。

世間で見るのは引数なしプロシージャ。引数？って方はこちら。

メリット

  1. マクロ実行できる
  2. 引数が無いのでマウスクリックで実行できる
  3. デバッグ時の実行が簡単

デメリット

あるかな？

  1. 引数が無いと何を処理するプロシージャか一見わからない
  2. Excelのセルやグローバル変数を使いがち。で読みにくい？
  3. となると、プロシージャごとにExcelのセルやグローバル変数？をチェックが必要で。読みにくい

以下は、標準モジュールのコード

Option Explicit

Sub main()
    a
End Sub


Sub a(Optional x = 1)
    Debug.Print x
End Sub

aプロシージャは、引数があるから実行できない。いくらOptionalでも。しかし、mainは引数無しだからマウスクリックで実行できる。それに、マクロ登録も可能。

カテゴリー: Excel基本操作, 2 VBEを使うための基本操作と知識 | コメントする