[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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) を実行してみてください。 エラーになるかどうか。
(???) 2018/06/08(金) 16:37
(隠居じーさん) 2018/06/08(金) 16:40
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
追加質問で申し訳ないのですが、
この出力処理の前に、抽出処理をしており、
絞り込み方法を、
『 .Range("A1").AutoFilter Field:=23, Criteria1:="=加藤", Operator:=xlOr, Criteria2:="=佐藤"』から、
『.Range("A1").AutoFilter Field:=23, Criteria1:=Array("加藤", "佐藤", "伊藤"), _
Operator:=xlFilterValues』 に変更した後から今回のエラーが出るようになりました。 Subプロージャは分けているので関係ないと思っていたのですが、関係しているのでしょうか・・・?
(あーちゃん) 2018/06/08(金) 17:59
j = .AutoFilter.Filters.Count If ws_取引先.Cells(j, 2) = "" Then Exit For はどのような狙いがあるのでしょうか
単純に取引先シートのB列にあるリストを使って、A列のフラグで処理対象か否かを判定して、処理対象のものだけオートフィルタで抽出してそれぞれ新規ブックへコピーしてるのかなとおもったんですが、読み違えてますでしょうか。
(もこな2) 2018/06/08(金) 20:01
>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プロージャは分けているので関係ないと思っていたのですが、関係しているのでしょうか・・・?
とのことですが、別プロシージャの話ということですし、問題のコードは、処理前にオートフィルタを一度解除してますから関係ないように思うのですが・・・
(もこな2) 2018/06/09(土) 08:42
すでに指摘がありますが、↑がまずいですね。
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"を使わない方法にしてもいいかもです。
(もこな2) 2018/06/09(土) 15:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.