• 締切済み

実行時エラー’438　の解消

QNo.3040449 と同じ内容の質問です。本を見ながらコードを書いてみましたが、 実行時エラー’438 オブジェクトはこのプロパティまたは メソッドをサポートしていません。となってしまいました。 どこを変更すれば、よいのでしょうか？ また、元データをそれぞれ、＜条件＞シートの内容で抽出し、 可視セルのみ＜集約＞にコピーしたのち、他の２つの ファイルのデーターも先に貼り付けたデータの最後行の 下へコピーしたいのですが、コードがよくわかりません。 教えて頂ければ幸いです。 集約するシート：テスト用.xls sheet1.(集約）　sheet2.(条件） 元のデータ： 金額一覧表(01～03).xls Sheet1.(01～03) 　 金額一覧表(04～06).xls Sheet1.(04～06)　 金額一覧表(07～10).xls Sheet1.(07～10) ＜各データは1.5万～３万件＞ Sub 抽出後コピー() Dim myTbl As Range, myQry As Range, sakiRang As Range Dim Nx As Long Dim WBK As Workbook, WB1 As Workbook Dim SH1 As Worksheet, SH2 As Worksheet Set WBK = Workbooks("テスト用.xls") Set WB1 = Workbooks("金額一覧表(01～3).xls") Set SH1 = WB1.Sheets("(01-03)") WBK.Activate WB1.Activate Nx = SH1.Range("R65536").End(xlUp).Row Set myTbl = WB1.SH1.Range("A1:Nx") ←ここでデバック Set myQry = WBK.Sheets("条件").Range("A1:F27") Set sakiRang = WBK.Sheets("集約").Range("A1") myTbl.AdvancedFilter xlFilterCopy, myQry, sakiRng End Sub

みんなの回答

  • zap35
  • ベストアンサー率44% (1383/3079)
回答No.1

＞Set myTbl = WB1.SH1.Range("A1:Nx") ←ここでデバック 良く見てください。　A1:Nx　なんていうアドレス表記はありえませんよ。範囲がA1～R列の最終行までなら 　.Range("A1:R" & Nx) でしょう

nekonote19
質問者

お礼

お返事おそくなってすみません。 ご回答ありがとうございます。 　.Range("A1:R" & Nx) と入れてみたのですが、やはり同じところでデバックしてしまいました。 どうも、Set myTbl を変数で宣言しても、サポートしていないようです。 とりあえず、別のやり方で解決できました。 ありがとうございました。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • ＶＢＡのコピー

    ＶＢＡのコピー Dim xls As New Excel.Application Dim wbk As New Excel.Workbook Dim sh3 As Worksheet Set sh3 = Worksheets("全") sh3.Activate sh3.Range("A1:Z65536").Select Selection.Clear Set wbk = xls.Workbooks.Open("\\***.***.*.***\管理\全データ抽出.xls") wbk.Worksheets("全").Activate 'ワークシートをアクティブにする wbk.Worksheets("全").Range("A1:Z65536").Copy 'コピーする 'ActiveSheet.Paste Destination:=Worksheets("全").Range("A1") '貼り付ける Worksheets("全").Range("A1").PasteSpecial Paste:=xlPasteValues wbk.Close SaveChanges:=False 'Worksheets("メイン").Cells(1, 1).Select を実行すると　『wbk.Close SaveChanges:=False』のところで クリップボードに大きな情報があります。・・・・ と言うメッセージがでて必ずとまってしまうのですが メッセージをでないようにしたいのですが 教えてください。お願いします。

  • VBA 実行時エラーで、"プロパティまたはメソッド

    ・Sheet1(コード) Private Sub CommandButton1_Click() Call aaa End Sub ・Module1(コード) Sub aaa() Dim wb As Workbook Dim ws As Worksheet Workbooks.Open ("c:\test.xls") Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") wb.ws.Range("A2").Value = "CCC" End Sub wb.ws.Range("A2").Value = "CCC"の部分で 以下の実行エラーが出ます。 ------------------------------------------------------------------------ 実行時エラー'438': オブジェクトは、このプロパティまたはメソッドをサポートしていません。 ------------------------------------------------------------------------ Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") の部分で特にエラーも出ないので、オブジェクトの取得は成功していると 思うのですが、WorkSheetオブジェクトのwsからRangeメソッドを呼ぶことが できません。 動かない原因と対策を教えてください！！

  • Excel VBAファイルがない場合メッセージ表示

    ExcelVBAでプログラムを実行させたときに2つのファイルを参照します。 　(1)結果コピー先ファイル 　(2)データ元ファイル この2つのファイルのうち、いずれかがなかった場合にメッセージを表示させたいのですが思うように表示されません。 以下のように動作させたいのですがうまくいきません。 　(1)2種類のファイルがないときには両方のメッセージを 　　1つの画面に表示したい。 　(2)どちらか一方のファイルがないときには、 　　エラーメッセージを表示させエラーのないファイルを 　　表示させない。 　　　※いろいろ試したら(a)がないメッセージが表示されたが、 　　　　(b)のファイルが表示された。 　(3)正常に処理が終了した場合は、完了メッセージを表示したい。 途中まで書いてみたコードは以下の通りです。 　※実行コードは中略します。 '////////////////////////////////////////////////////// Sub test1() Dim sMsg As String Dim sMyDir As String sMyDir = ThisWorkbook.Path & "\" Dim Ws As Worksheet Dim vTgYear As Variant Dim Wb As Workbook Set Wb = Workbooks("算出プログラム.xls") Set Ws = Wb.Sheets("入力内容") vTgYear = Ws.Range("D17").Value With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim sWbkName As String, StName As String Dim wbk結果1 As Variant sWbkName = "3_結果\結果.xls" 　　StName = "Sheet1" Dim sWbkSubName As String sWbkSubName = "1_算定表\" & vTgYear & "_算定表.xls" Dim Kname As String, Mname As String Kname = sMyDir & sWbkName Mname = sMyDir & sWbkSubName Dim buf As String On Error GoTo myError Open sMyDir & "3_結果\結果.xls" For Input As #1 Line Input #1, buf Close #1 On Error GoTo ErrorHandler2 If Dir(Mname) <> "" Then Workbooks.Open Filename:=Mname, Password:="aaaaa" Else Dim Wb1 As Workbook Set Wb1 = Workbooks("結果.xls") Set wbk結果 = Wb1.Sheets(StName) Dim wbkA As Variant Dim sShtName As String sShtName = "地域1" Dim Wb2 As Workbook Set Wb2 = Workbooks(vTgYear & "_算定表.xls") Set wbk地域A = Wb2.Sheets(sShtName) wbk結果.Range("F9:N9").Value = wbk地域A.Range("AB7:AK7").Value wbk結果.Range("F10:N10").Value = wbk地域A.Range("AB51:AK51").Value wbk結果.Range("F11:N11").Value = wbk地域A.Range("AB95:AK95").Value wbk結果.Range("F12:N12").Value = wbk地域A.Range("AB139:AK139").Value wbk結果.Range("F13:N13").Value = wbk地域A.Range("AB183:AK183").Value wbk結果.Range("F14:N14").Value = wbk地域A.Range("AB227:AK227").Value wbk結果.Range("F15:N15").Value = wbk地域A.Range("AB271:AK271").Value wbk結果.Range("F16:N16").Value = wbk地域A.Range("AB315:AK315").Value ≪後略≫ Application.DisplayAlerts = False wbk結果1.SaveAs Filename:=sMyDir & "3_結果\" & vTgYear & "_テスト.xls" ' Application.DisplayAlerts = True With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Workbooks(vTgYear & "_算定表.xls").Close SaveChanges:=False MsgBox "計算期間" & "「" & kenko_Label_10 & "」で" & vbLf & "ファイルを作成しました。", vbInformation Close #1 Exit Sub myError: MsgBox "出力先の「結果_健康寿命」ファイルが存在しません。" & _ vbLf & "処理を終了します。", vbOKOnly + vbExclamation Exit Sub ErrorHandler2: MsgBox "指定年の「長野県健康寿命算定表」" & _ vbLf & "ファイルが存在しません。処理を終了します。", vbOKOnly + vbExclamation End If End Sub '////////////////////////////////////////////////////// メッセージ画面以外は正常に動作することを確認しています。 メッセージ画面について教えてください。 素人で申し訳ありませんが、よろしくお願い致します。

  • Excel VBA ：2回目以降実行で貼り付けるセルが変わる

    いつもお世話になっております。 ExcelのVBAでご質問があります。 指定した日付のデータを抽出して 別のシートに貼り付けるサブプロシージャなのですが、 下記のようなコードを書きましたところ、 貼り付けるセルが何故か("BH2")になってしまいます。 コードの一部を変えて、実行するとコード通り ("BH3")のセルに貼り付けてくれるのですが、 もう一度別の日付を入力して実行すると ("BH2")のセルに貼り付けてしまうのです。 何が原因なのでしょうか・・・？ ちなみに最初にコードを書いたときは 貼り付け先は("BH2")のセルにしていましたが 途中で間違いに気づき、("BH3")に書き換えました。 これが関係あるのでしょうか。 何卒よろしくお願いします。 ------------------------------------------------------ Sub 予定表() Application.ScreenUpdating = False 'ファイルオープン Dim i As Integer For i = 1 To Workbooks.Count If (Workbooks(i).Name = "予定表.xls") Then Exit For End If Next If (i > Workbooks.Count) Then Workbooks.Open Filename:="\\Dress\予定表.xls" ' 予定表の取り込み Dim date1 As Date Dim fmt As String Dim objList1 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim Rng As Range Dim sh1 As Worksheet Dim sh4 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("製品.xls") Set wb2 = Workbooks("予定表.xls") Set sh1 = wb1.Worksheets("Sheet1 (3)") Set sh4 = wb2.Worksheets("1") '------------------------------------------------------------------------- sh1.Range("BH3:BN20").ClearContents '日付のチェック Do date1 = Application.InputBox("日を入力して下さい。", "印刷日入力", Type:=2) If VarType(date1) = vbBoolean Then Exit Sub If IsDate(date1) = False Then MsgBox date1 & "　は、日付ではありません。" Loop Until IsDate(date1) With sh4 Set objList1 = .ListObjects("予定") fmt = .Range("A2").NumberFormatLocal '書式を取る date1 = Format(date1, fmt) '入力文字の書式変更 objList1.Range.AutoFilter Field:=1, Criteria1:=date1 Set Rng = objList1.Range.SpecialCells(xlCellTypeVisible) Rng.Copy sh1.Range("BH3") objList1.Range.AutoFilter Field:=1 End With Application.CutCopyMode = False Range("R3").Value = date1 Set Rng = Nothing Set objList1 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set sh1 = Nothing Set sh4 = Nothing End Sub

  • 転記したデータを基にして検索表示させる方法

    下記のようにシートＡのデータをシートＢ（Ａ列）へ転記した後に、転記したデータを基にしてデータベースから検索した結果をシートＢ（Ｂ列）に表示したいのですが、マクロを実行すると「型が一致しません」というエラーになります。 どのようにしたらエラーにならないのか… どうぞよろしくお願いします。 Sub レコード転記() Dim myTbl As Range, sakiRng As Range Set myTbl = Sheets("Ａ").Range("B6:B81") Set sakiRng = Sheets("Ｂ").Range("A5") myTbl.Copy sakiRng.PasteSpecial xlPasteAll sakiRng.PasteSpecial xlPasteColumnWidths End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim r As Variant, myRange As Range Set myRange = Workbooks("入力フォーム.xls").Worksheets("一覧表").Range("社名") With Target If Target.Column = 1 Then r = Application.WorksheetFunction _ .Match(Target.Value, myRange, 0) Cells(Target.Row, 2) = Workbooks("入力フォーム.xls").Worksheets("一覧表").Range("N1").Offset(r - 1).Value End If End With End Sub

  • エクセルVBAのオートフィルタについて

    いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub （一部省略しています）

  • vbaエラーの原因

    先ほどまで動いていたのですが、保存後にエラーとなりました。 実行時エラー1004または、マクロ実行時にエラー400と表示されます。 どこが変わったのか、自分でもわからず、苦戦しています。 シート２（左から2番目）に氏名と読み取りパスワードが記載されています。 それをつかって、氏名をファイル名としたエクセルファイルを読み込ませ、 印刷をさせるまでの一連の動作となります。 --- Sub printcode() Dim wbk As Workbook Dim targetRange As Range Dim i As Long Set targetRange = ThisWorkbook.Worksheets(2).Range("A1").CurrentRegion For i = 2 To targetRange.Rows.Count Set wbk = Workbooks.Open(targetRange.Cells(i, 1).Value & ".xls", Password:=targetRange.Cells(i, 2).Value) Sheets("Sheet1").PrintPreview 'PrintOut wbk.Close Set wbk = Nothing Next i End Sub --- 印刷実行前に動作確認として、プレビューコマンドを使用しています。 どの辺にエラーがあるのか、一つずつ確認しているのですが、おそらく前半と思われます。 ご指摘いただけますでしょうか。よろしくお願いいたします。

  • VBA 実行時エラー1004(その2)

    毎度お世話になっております。 シート「sheet2」のA列のリスト内容を、シート「M_得意先」のリストからVLOOKUPして、指定のセルに書き出していくというコードを作成してみたのですが、VLOOKUPを実行する段階でエラーが出てしまいます。 少し変更して、同一シート内でのVLOOKUPは問題なく実行できたのですが...原因をご存知の方教えてください。 Dim b As String Dim endRcell2 As Long Dim cnt10 As long Sheets("sheet2").Select Sheets("sheet2").Range("A1").CurrentRegion.Select 'データ全体選択 Selection.SpecialCells(xlCellTypeLastCell).Select '最終行検出 endRcell2 = ActiveCell.Row cnt10 = 2 Do ↓実行時エラー1004が出る行 b = Application.WorksheetFunction.VLookup(Sheets("Sheet2").Range("A" & cnt10).Value, Sheets("M_得意先").Range(Cells(1, 1), Cells(endRcell, 2)), 2, False) ↑実行時エラー1004が出る行 Sheets("sheet2").Range("E" & cnt10).Value = b cnt10 = cnt10 + 1 Loop Until cnt10 = endRcell2

  • エクセルのデータの変更

    今マクロでSheet1にあるデーターをSheet２・３・４・５・６・７それぞれにそれぞれの抽出条件で抽出できるよう設定してあるのですが、このSheet１を他のBookに変更した場合のマクロの変更の仕方を教えてください。 ちなみにいまは 標準モジュールに Sub 定義() Dim myTbl As Range, myQry As Range, sakiRng As Range End　Sub と各シートの[Worksheet　Activate]　に Private Sub Worksheet_Activate() Set myTbl = Sheets(１).Range("myTbl") Set myQry = Sheets(８).Range("A_抽出条件") Set sakiRng = Sheets(２).Range("A3：AR3") myTbl.AdvancedFilter xlFilterCopy, myQry, sakiRng Dim rw As Long '入力最終行 rw = Range("I65536").End(xlUp).Row With Application Range("I" & rw + 1) = .Sum(Range("I1:I" & rw)) Range("AO" & rw + 1) = .SumIf(Range("AP1:AP" & rw), "済", Range("AO1:AO" & rw)) Range("AQ" & rw + 1) = .Sum(Range("AQ1:AQ" & rw)) End With End　Sub となっています。

  • 実行時エラーの原因がつかめない（ＥｘｃｅｌＶＢＡ）

    下記コードで実行時エラーの原因がつかめません。どなたか助けて ください。Sheet5のＡ，Ｂ列のデータを　Sheet6 のＡ，Ｂ列に 一定の範囲で逆順にコピーする操作です。 Dim Dn As Integer, Zn As Integer Dn = Sheets("sheet1").Range("E37").Value / 8 + 0.5 Zn = Round(Dn)　‘ Sheets("Sheet6").Range("A1:A65536").ClearContents Xn2 = Sheets("Sheet3").Range("D65536").End(xlUp).Row - 5　 Xn1 = Sheets("Sheet5").Range("A65536").End(xlUp).Row I = 0 Do Ix = I + 1 Iz = Xn1 - I Sheets("Sheet6").Range("A" & Ix & " : B" & Ix).Value _ Sheets("Sheet5").Range("A" & Iz & " : B" & Iz).Value I = I + 1 Loop Until I = Xn2 * Zn + 1

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する