Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Pro : Excel 2016)
Worksheets.Openで取得したブックの全シートの特定行のデータ取得
投稿日時: 22/03/07 17:58:43
投稿者: nonotti

いつもお世話になっております。
 
早速ですが、
 
xlsmファイル内のA2へファイルディレクトリを入力すると、同ファイル内でA5:Dへ
A:取得したファイル名
B:シート名
C:最終更新日
D:K列の最大値(合計重量)
 
を取得すべくコードを引用しながら切り貼りして作成しました。(非常に読みづらいと思います。申し訳ございません。)
 
以下、コードです。

Sub Main_Proc()
    Dim MaxRow As Long
    Dim folderPath As String
    Dim shtMain As Worksheet
    Dim fso As Object
    Dim f As Object
    Dim nowRow As Long
    Dim ws As Worksheet                 '// 参照シート
    Dim wb As Workbook
    Dim i As Long
    Dim maxVal As Single
    Dim mv As Long
    Dim mr As Long
    
    
    '@参照するシートを変数に格納する
    Set shtMain = ThisWorkbook.Sheets("メイン")
    
    'Aデータ入力されているA列の最終行を取得する
    MaxRow = shtMain.Cells(shtMain.Rows.Count, 1).End(xlUp).Row
    
    'B最終行が5行目以降なら、5行目以降のA列とB列のセルをクリアする
    If MaxRow >= 5 Then
        shtMain.Range("A5:D" & MaxRow).Clear
    End If
    
    'CFileSystemObjectを変数に格納する
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    nowRow = 4
    
    'D指定されているフォルダに存在するファイル数分処理を繰り返す
    For Each f In fso.GetFolder(shtMain.Range("A2")).Files
    
        
            'FEXCELファイルを開く(読み取り専用、非表示)
            Set wb = Workbooks.Open(shtMain.Range("A2") & "\" & f.Name, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
            
     'G存在するシート数分繰り返す
     For i = 1 To wb.Sheets.Count
     
        Set ws = Sheets(1)
     
        mr = Cells(Rows.Count, "K").End(xlUp).Row
        maxVal = 0
    
            For mv = 3 To mr
            If Cells(mv, "K").Value <> "" Then
            maxVal = Cells(mv, "K").Value
            
            If Cells(mv, "K").Value > maxVal Then
            maxVal = Cells(mv, "K").Value
            End If
                
            End If

            Next
            
     
                'H現在行を次の行に変更する
                nowRow = nowRow + 1
        
                'Iファイル名をA列にセットする
                shtMain.Range("A" & nowRow) = f.Name
                
                'Jシート名をB列にセットする
                shtMain.Range("B" & nowRow) = wb.Sheets(i).Name
                
                'ファイルの最終更新日をC列にセット
                shtMain.Range("C" & nowRow) = f.DateLastModified
                
                'K列の最大値をD列にセット
                shtMain.Range("D" & nowRow) = maxVal
            
            'KEXCELファイルを閉じる
            wb.Close
            
               Next i
           
    Next
  
    
    'Lワークブックをクリアする
    Set wb = Nothing
    
    'MFileSystemObjectをクリアする
    Set fso = Nothing
       
    MsgBox "完了"
    
End Sub

 
実行自体は出来るのですが、問題点として
@ B:シート名はシート左端から取得されるが、D:K列の最大値(合計重量)は参照ブックを開いたとき、
  最初に表示されるシートから引っ張ってくる
  例)B:シート1のシート名,D:シート3のK列の最大値(合計重量)
A 実行後必ず『'Jシート名をB列にセットする』でオートメーションエラーが発生(i=2になっている)
B Aでオートメーションエラーになる為、全てのブックの一覧表ができない
 
業務上どうしても必要となるので、何卒お力添えを頂けると幸いでございます。
よろしくお願いいたします。

回答
投稿日時: 22/03/07 19:06:13
投稿者: mattuwan44

Option Explicit

Sub test()
    Dim myPath As String, buf As String, myName As String
    Dim s As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rngTo As Range
    Dim ix As Long
    
    With ThisWorkbook.Sheets("メイン")
        .UsedRange.Resize(, 2).Offset(5).ClearContents
        myPath = .Range("A2").Value
        Set rngTo = .Range("A5")
    End With
    
    buf = Dir(myPath & "\*.xlsx")
    Do While buf <> ""
        s = myPath & "\" & buf
        Set wb = Workbooks.Open(Filename:=s, _
                                ReadOnly:=True, _
                                IgnoreReadOnlyRecommended:=True)
                                
        For Each ws In wb.Worksheets
            ix = ix + 1
            rngTo(ix, 1).Value = wb.Name
            rngTo(ix, 2).Value = ws.Name
            rngTo(ix, 3).Value = FileDateTime(s)
            rngTo(ix, 4).Value = WorksheetFunction.Max(wb.Worksheets(3).Range("K:K"))
        Next
    
        wb.Close False
        Set wb = Nothing
        
        buf = Dir()
    Loop
End Sub

 
こんな感じですかね?動作確認はやってません。
バグあるかも。
やり方の参考になれば。。。
 
エラーは試しながらやらないと分からないので^^;

回答
投稿日時: 22/03/07 20:18:49
投稿者: simple

余り念入りに拝見したわけでもないのですが、
貴兄のコードについて気づいたことを列挙します。
見直してみてください。
(1)インデントをもう少し正確につけたほうが良いと思います。
(2)シートに関する繰り返しの処理のなかで、シートの指定が漏れている所が結構散見されます。
   シート指定がないと、その時にアクティブなシートを指定したものとみなされます。
   このことは、たぶんあなたにとって不幸をもたらすものと思われます。
   注意深くチェックしてみてください。
(3)ブックを開く処理のタイミングが悪いです。
   すべてのシートの繰り返しが終わらないうちに閉じてしまうのは気が早いです。
 
修正版をまた提示してもらうとよいと思います。

回答
投稿日時: 22/03/08 07:18:31
投稿者: simple

変数宣言のあたりとインデントに手を入れてみました。参考になりますか?
 

Sub Main_Proc()
    Dim fso         As Object
    Dim f           As Object
    Dim shtMain     As Worksheet
    Dim wb          As Workbook
    Dim ws          As Worksheet                 '// 参照シート
    Dim MaxRow      As Long
    Dim folderPath  As String
    Dim nowRow      As Long
    Dim i           As Long
    Dim maxVal      As Single
    Dim mv          As Long
    Dim mr          As Long

    '@参照するシートを変数に格納する
    Set shtMain = ThisWorkbook.Sheets("メイン")

    'Aデータ入力されているA列の最終行を取得する
    MaxRow = shtMain.Cells(shtMain.Rows.Count, 1).End(xlUp).Row

    'B最終行が5行目以降なら、5行目以降のA列とB列のセルをクリアする
    If MaxRow >= 5 Then
        shtMain.Range("A5:D" & MaxRow).Clear
    End If

    'CFileSystemObjectを変数に格納する
    Set fso = CreateObject("Scripting.FileSystemObject")

    nowRow = 4

    'D指定されているフォルダに存在するファイル数分処理を繰り返す
    For Each f In fso.GetFolder(shtMain.Range("A2")).Files

        'FEXCELファイルを開く(読み取り専用、非表示)
        Set wb = Workbooks.Open(shtMain.Range("A2") & "\" & f.Name, _
                                ReadOnly:=True, IgnoreReadOnlyRecommended:=True)

        'G存在するシート数分繰り返す
        For i = 1 To wb.Sheets.Count
            Set ws = Sheets(1)                              '■sheets(i) では?
            mr = Cells(Rows.Count, "K").End(xlUp).Row       '■シート指定無し
            maxVal = 0

            For mv = 3 To mr
                If Cells(mv, "K").Value <> "" Then          '■
                    maxVal = Cells(mv, "K").Value           '■
                    If Cells(mv, "K").Value > maxVal Then   '■
                        maxVal = Cells(mv, "K").Value       '■
                    End If
                End If
            Next

            'H現在行を次の行に変更する
            nowRow = nowRow + 1

            'Iファイル名をA列にセットする
            shtMain.Range("A" & nowRow) = f.Name

            'Jシート名をB列にセットする
            shtMain.Range("B" & nowRow) = wb.Sheets(i).Name

            'ファイルの最終更新日をC列にセット
            shtMain.Range("C" & nowRow) = f.DateLastModified

            'K列の最大値をD列にセット
            shtMain.Range("D" & nowRow) = maxVal

            'KEXCELファイルを閉じる     ’■ブックを閉じる位置が不適切
            wb.Close
        Next i
    Next

    'Lワークブックをクリアする
    Set wb = Nothing
    'MFileSystemObjectをクリアする
    Set fso = Nothing
    MsgBox "完了"
End Sub

繰り返しのための変数は、iよりもkのほうが間違いにくいですね。
なお、上記は動作を確認もしていませんし、保証するものではありません。
そちらで検討する際の参考のためのものです。

回答
投稿日時: 22/03/19 09:50:44
投稿者: WinArrow
投稿者のウェブサイトに移動

致命的なことではありませんが、

            'FEXCELファイルを開く(読み取り専用、非表示)
            Set wb = Workbooks.Open(shtMain.Range("A2") & "\" & f.Name, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)

で、コメントの「非表示」について
ブックを非表示にしたいということでなんですか?
もし、ブックを非表示にしたいのでしたら、
このコードでは対応できないと思います。
 
 
ブックを非表示にするコード例
 
    Windows(wb.Name).Visible = False

 
蛇足ですgが、
ReadOnly:=True
で開いているので、
>IgnoreReadOnlyRecommended:=True
は、無駄な指定と思います。
確認してみてください。
 

トピックに返信