[[20180608151857]]　『VBAエラー91　オブジェクト変数またはWithブロッメx（あーちゃん）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『VBAエラー91　オブジェクト変数またはWithブロック変数が設定されていません』（あーちゃん）

エラー91が発生してしまいますが、どこに問題があるのかわからないため、ご教示いただきたいです。

やりたい処理は、選択した業者のみ業者ごとに別ブックに新規名前をつけて保存する。

複数選択した際に、2個目以降で名前をつけて保存するときにエラーが発生します。

以下コードです。
長くてすみません。
デバックを確認すると、『 Path = WSH.SpecialFolders("Desktop") & "\" & ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) & Format(Date, "yyyymmdd") & ".xlsx"』に問題があるようです。

Sub データ出力() 

    Dim i As Long, j As Long, ii As Long


    Dim m_book As Workbook
    Dim m_sheet As Worksheet
    Dim ws_Sheet1 As Worksheet
    Dim ws_取引先 As Worksheet
    Dim Path As String, WSH As Variant


    Dim lastrow As Long
    Dim lastcol As Long


    Application.ScreenUpdating = False


    Set m_book = ThisWorkbook
    Set m_sheet = m_book.ActiveSheet
    Set ws_Sheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws_取引先 = ThisWorkbook.Worksheets("取引先")
    Set WSH = CreateObject("Wscript.Shell")

STEP1:

　 With ws_Sheet1 

        .Select
        .Range("A1").Select
        If .AutoFilterMode Then
            j = .AutoFilter.Filters.Count
            'オートフィルター解除
            Selection.AutoFilter
        End If


        'オートフィルターを設定
        Selection.AutoFilter
　　　　　　'チェックされた取引先を絞り込み、「Sheet1」から「新規BOOK」にコピー & 名前を付けて保存
　　　　　　For j = 2 To 1000
            If ws_取引先.Cells(j, 2) = "" Then Exit For


            If ws_取引先.Cells(j, 1) <> "" Then


                'データ絞り込み（H列の「コード」）
                .Range("A1").AutoFilter Field:=8, Criteria1:=ws_取引先.Cells(j, 2)


                '新規BOOKを作成
                Workbooks.Add


                '絞り込みデータを新規BOOKにコピー
                .Range("A1").CurrentRegion.Offset(0, 0).Copy ActiveWorkbook.ActiveSheet.Range("A1")


                With ActiveWorkbook


                    'シート名変更
                    .ActiveSheet.Name = Format(Date, "yyyymmdd")     


                     Path = WSH.SpecialFolders("Desktop") & "\" & ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) & Format(Date, "yyyymmdd") & ".xlsx"
                     ActiveWorkbook.SaveAs Path
                     Set WSH = Nothing


                    'BOOK保存時のメッセージを表示しない→上書き保存される
                    Application.DisplayAlerts = False
                    '上書き保存
                    .SaveAs Filename:=ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) & Format(Now(), "yyyymmdd") & ".xlsx"
                    'BOOKを閉じる
                    .Close
                    Application.DisplayAlerts = True


                End With
            End If
        Next j
    End With


    'オートフィルターを解除
    ws_Sheet1.Select
    Selection.AutoFilter


    ws_取引先.Select


    MsgBox "データ出力 処理完了"

End Sub

恐れ入りますが、お力添えいただきたく、お願い申し上げます。

＜ 使用 Excel：Excel2016、使用 OS：Windows7 ＞ 

 pathをどこか空きセルに書き出し、それをここに
アップ、されると
回答が付きやすいかもです。
確認してませんが
マクロが含まれたBOOKだと、拡張子とファイルフォーマットの整合が取れてないと
ダメな場合もあったような気が。。。＾＾；
違ったいましたら済みません。

（隠居じーさん） 2018/06/08(金) 16:09

ファイル名のフルパスに問題は無いでしょうか？
ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) & Format(Now(), "yyyymmdd") & ".xlsx" の部分を、単純な "test.xlsx" とかに変えて動かすとどうなるでしょう？

ファイル名を変えると保存するようならば、ブレークポイントを設定するか、元のファイル名に戻してエラー停止させてから、イミディエイトウィンドウ上で ? ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) を実行してみてください。 エラーになるかどうか。
（???） 2018/06/08(金) 16:37

？？？　さんが回答されていますが。。。　＾＾
当方環境でテスト。。。pathはこちらのpathですので分からないですが。。。
それ以外はエラーありません。
なにかの参考まで　m(__)m

（隠居じーさん） 2018/06/08(金) 16:40

＞？？？さん
回答ありがとうございます。　
下記に変更してみましたが、同じエラーが出てしまいます。
　
また、フルパスに間違いは無いかと思います。。
下記を参考に作成しました。
（デスクトップに取引先名、日付を入れて名前をつけて保存と言う作業を選択数分繰り返したいため）

Sub Sample3() 
    Dim Path As String, WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    Path = WSH.SpecialFolders("Desktop") & "\"
    ActiveWorkbook.SaveAs Path & "Sample1.xls"
    Set WSH = Nothing
End Sub

＞隠居じーさんさん
テストまでしていただきありがとうございます。
エラーが無いとの事、やはり当方Pathに問題があるのでしょうか。。。
初心者のため、Pathをちゃんと理解できていないので改めて勉強します。

（あーちゃん） 2018/06/08(金) 17:29

ん？、ファイル名拡張子が .xls ですか？ 旧形式にしたいならば、FileFormat:=xlExcel8 の指定をしないといけませんよ。 現状は拡張子だけ .xls ですが、中身は新形式の .xlsx になっていると思います。 元のコードのように、.xlsx で保存してはいかがでしょう？
（???） 2018/06/08(金) 17:44
＞？？？さん
拡張子はxlsxです。
参考にした記事が古いものだったので、xlsになっていますが、xlsxに修正し、コード入力しています。
参照した記事をそのままこぴぺしておりました、混乱させてしまい申し訳ありません。

追加質問で申し訳ないのですが、
この出力処理の前に、抽出処理をしており、
絞り込み方法を、
『 .Range("A1").AutoFilter Field:=23, Criteria1:="=加藤", Operator:=xlOr, Criteria2:="=佐藤"』から、
『.Range("A1").AutoFilter Field:=23, Criteria1:=Array("加藤", "佐藤", "伊藤"), _ 

                                            Operator:=xlFilterValues』
に変更した後から今回のエラーが出るようになりました。
Subプロージャは分けているので関係ないと思っていたのですが、関係しているのでしょうか・・・？

（あーちゃん） 2018/06/08(金) 17:59

回答でなくて、便乗質問ですがVBA上でFormat(Now(), "yyyymmdd") と、したいときに、Now関数つかうメリットってあるんでしょうか?
個人的にはDATEにしちゃうんですが、、
（もこな２） 2018/06/08(金) 19:28
これまた、回答でなくて確認ですが、 
 j = .AutoFilter.Filters.Count
 If ws_取引先.Cells(j, 2) = "" Then Exit For
はどのような狙いがあるのでしょうか

単純に取引先シートのB列にあるリストを使って、A列のフラグで処理対象か否かを判定して、処理対象のものだけオートフィルタで抽出してそれぞれ新規ブックへコピーしてるのかなとおもったんですが、読み違えてますでしょうか。
（もこな２） 2018/06/08(金) 20:01

＞複数選択した際に、2個目以降で名前をつけて保存するときにエラーが発生します。

＞Set WSH = Nothing

これの位置がわるいのでしょうか？
それを最後に移動すると大丈夫と思います。

それで解決だと思いますが
ムダも多いので、書き換えてみました。 

 Option Explicit


 Sub データ出力2()
    Dim j As Long
    Dim m_sheet As Worksheet
    Dim ws_Sheet1 As Worksheet
    Dim ws_取引先 As Worksheet
    Dim wb As Workbook
    Dim myPath As String


    Application.ScreenUpdating = False


    Set ws_Sheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws_取引先 = ThisWorkbook.Worksheets("取引先")


    myPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & "\"


    With ws_Sheet1.Cells(1).CurrentRegion
        .AutoFilter
        For j = 2 To ws_取引先.Cells(Rows.Count, 2).End(xlUp).Row
            If ws_取引先.Cells(j, 1) <> "" Then
                .AutoFilter Field:=8, Criteria1:=ws_取引先.Cells(j, 2)
                Set wb = Workbooks.Add(xlWBATWorksheet)
                wb.Sheets(1).Name = Format(Date, "yyyymmdd")
                .Copy wb.Sheets(1).Cells(1)
                 myPath = myPath & ws_取引先.Cells(j, 2) & "_" & ws_取引先.Cells(j, 3) & Format(Date, "yyyymmdd") & ".xlsx"
                Application.DisplayAlerts = False
                 wb.SaveAs myPath, xlOpenXMLWorkbook
                wb.Close
                Application.DisplayAlerts = True
           End If
        Next j
        .AutoFilter
    End With


    ws_取引先.Select
    MsgBox "データ出力 処理完了"


 End Sub

（マナ） 2018/06/08(金) 21:00

暇つぶしに整理しよかな〜とおもっていたらマナさんが整理してくださった。

私が考えても同じような感じになりますが、別の部分で
＞『 .Range("A1").AutoFilter Field:=23, Criteria1:="=加藤", Operator:=xlOr, Criteria2:="=佐藤"』から、
＞『.Range("A1").AutoFilter Field:=23, Criteria1:=Array("加藤", "佐藤", "伊藤"), _
＞ Operator:=xlFilterValues』
に変更した後から今回のエラーが出るようになりました。
＞Subプロージャは分けているので関係ないと思っていたのですが、関係しているのでしょうか・・・？

とのことですが、別プロシージャの話ということですし、問題のコードは、処理前にオートフィルタを一度解除してますから関係ないように思うのですが・・・
（もこな２） 2018/06/09(土) 08:42

＞Set WSH = Nothing

すでに指摘がありますが、↑がまずいですね。
WSHをNothingにしているので2回目では変数にオブジェクトがセットされてないので、
『VBAエラー91　オブジェクト変数またはWithブロック変数が設定されていません』
となります。

そもそも、
Set WSH = Nothing
と書かなくても不都合は全くないので書かなくてもいいです。
（絶対書くという流儀の人も居ますが。。。）
それから、ループの中で、毎度
　＞WSH.SpecialFolders("Desktop")
↑を取得しておかなくてもループの外で1回取得しておけば、
値は変わらないので、その辺は直した方がいいとは思います。
（その書き方でも意図した結果は得られるとは思いますが。。。）

デバッグがてら、自分なりに書き直したので参考になれば。。。
大きなお世話ならごめんなさいです。
参考になれば。。。

Option Explicit

Sub データ出力() 

    Dim rngData As Range
    Dim rngOutPutFlg As Range
    Dim c As Range
    Dim wbTemp As Workbook
    Dim wsCopyTo As Worksheet
    Dim myPath As String
    Dim myFileName As String


    'Application.ScreenUpdating = False


    '元となるセル範囲の取得
    With ThisWorkbook.Worksheets
        Set rngData = .Item("Sheet1").Range("A1").CurrentRegion
        With .Item("取引先").Range("A1").CurrentRegion
            On Error Resume Next
            Set rngOutPutFlg = Intersect(.Columns(1), .Offset(1)).SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
        End With
    End With
    If rngOutPutFlg Is Nothing Then
        MsgBox "チェックが入ってません。終了します。"
        Exit Sub
    End If
    'フィルターが掛かっていたら全表示
    With rngData.Worksheet
        If .AutoFilterMode Then .ShowAllData
    End With


    '取引先のフラグが立っているセルの巡回
    For Each c In rngOutPutFlg.Cells
        With rngData
            .AutoFilter Field:=8, Criteria1:=c.Value
            If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                If wbTemp Is Nothing Then
                    .Worksheet.Copy
                    Set wbTemp = Workbooks(Workbooks.Count)
                    Set wsCopyTo = wbTemp.Worksheets(1)
                    wsCopyTo.UsedRange.Delete
                Else
                    With wbTemp.Worksheets
                        Set wsCopyTo = .Add(after:=.Item(.Count))
                    End With
                End If
            End If
            .Copy wsCopyTo.Range("A1")
        End With
        wsCopyTo.Name = Format(Date, "yyyymmdd")
    Next
    rngData.AutoFilter


    myPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & "\"
    '一時的に作ったブックの各シートを新しいブックとして保存する。
    For Each wsCopyTo In wbTemp.Worksheets
        wsCopyTo.Copy
        With Workbooks(Workbooks.Count)
            With .Worksheets(1)
                myFileName = .Cells(2, 2).Value & "_" & .Cells(2, 3).Value & .Name
            End With
            Application.DisplayAlerts = False
            .SaveAs myPath & myFileName & ".xlsx"
            Application.DisplayAlerts = True
            .Close False
        End With
    Next
    wbTemp.Close False


    ws_取引先.Select
    MsgBox "データ出力 処理完了"
End Sub

（まっつわん） 2018/06/09(土) 11:06

なるほど、犯人はソイツでしたか。

であれば、デスクトップのパスを掴みたいだけのようなので 

 Environ("UserProfile") & "\デスクトップ"

みたいに"Wscript.Shell"を使わない方法にしてもいいかもです。
（もこな２） 2018/06/09(土) 15:26

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.