コードのチェックをお願い 致します

このQ&Aのポイント
  • 2種類のブックのデータを追加した1つのブックに貼り付けるコードです。
  • 指定のセル値を検索し、それに基づいてデータをコピーして貼り付ける処理が含まれています。
  • 一部の処理でエラーが発生する可能性があります。
回答を見る
  • ベストアンサー

このコードのチェックをお願い致します。

2種類のブックのデータを → 追加した1つのブックに貼り付けます。 下記 「'------ここからエラーになる----」 からエラーになります。 エラー番号 91 「オブジェクト変数またはWith ブロック変数が設定されていません」 以上 下記コードのチェックをお願い致します。 ------------------------------ Sub tes1() Dim fWord As String, fAdd, c, wb As Workbook fWord = "1" Set wb = Workbooks.Add(xlWBATWorksheet) Workbooks("ああ.CSV").Activate Rows("1:1").Select Selection.Insert Shift:=xlDown With Workbooks("ああ.CSV").Worksheets(1).Range("F:F") Set c = .Find(fWord, LookIn:=xlValues) If Not c Is Nothing Then fAdd = c.Address Do c.Offset(0, 2).Resize(8, 1).Copy wb.Worksheets(1).Range("B65536").End(xlUp). _ Offset(1, 0).PasteSpecial Paste:=xlAll, _ Transpose:=True Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> fAdd End If End With Application.CutCopyMode = False Call tes2 End Sub '-------------------- Sub tes2() Dim aWord As String, aAdd, c, wb As Workbook aWord = "1" Workbooks("いい.CSV").Activate With Workbooks("いい.CSV").Worksheets(1).Range("A:A") Set c = .Find(aWord, LookIn:=xlValues) If Not c Is Nothing Then aAdd = c.Address Do c.Offset(0, 23).Resize(1, 1).Copy '------ここからエラーになる------------------------ wb.Worksheets(1).Range("B65536").End(xlUp). _ Offset(1, 0).PasteSpecial Paste:=xlAll, _ Transpose:=True Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> aAdd End If End With Application.CutCopyMode = False End Sub

質問者が選んだベストアンサー

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

wbはSub1、Sub2それぞれで定義していますので、名前は同じでも別の変数として扱われます。Sub1でSetした値はSub2に引き継がれないのでエラーになるのではありませんか Sub1でSetした値をSub2に引き継ぎたいなら Dim wb As Workbook Sub1() End Sub Sub2() End Sub のように変数を宣言してください。またはCallの時に引数としてwbを渡す方法もあります

oshietecho-dai
質問者

お礼

ご回答、誠に有難うございました。

関連するQ&A

  • 「変数の宣言」 が違うのでしょうか?

    Excel 2002 です 下記コードはなんとか動作するんですが、 例えば、「Cells(1, 8).Value」が「2」の時、 「"G:G"」列の「12」にも動作してしまうので、 必ず、「2」だけに動作させたいんですが、 どのように記述すればよいでしょうか? 「Cells(1, 8).Value」と「"G:G"」列は、1~20までの数字しかありません。 他に、おかしな記述箇所がありましたら、教えて下さいませ。 何卒よろしくお願い致します。 ---------------------- Sub 一セルずつ貼付ける() Dim fWord As Integer, fAdd, c fWord = Cells(1, 8).Value With Workbooks("ああ.xls").Worksheets(1).Range("G:G") Set c = .Find(fWord, LookIn:=xlValues) If Not c Is Nothing Then fAdd = c.Address Do c.Offset(0, 5).Copy Worksheets(Worksheets.Count).Range("D65536").End(xlUp). _ Offset(1, 0).PasteSpecial Paste:=xlAll, _ Transpose:=True Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> fAdd End If End With End Sub

  • マクロのループが次へ進みません!!

    Sub 不要な行を削除() Dim fWord As String, fAdd, c, wb As Workbook fWord = "ああ"  '←"ああ"の行は複数あります '下記3行はなくてもよいかも。以前、あったほうがうまく実行できましたので。 Workbooks("てすと.xls").Activate Rows("1:1").Select Selection.Insert Shift:=xlDown With Workbooks("てすと.xls").Worksheets(1).Range("A:A") Set c = .Find(fWord, LookIn:=xlValues) If Not c Is Nothing Then fAdd = c.Address Do   c.Offset(-1, 0).EntireRow.Delete    c.Offset(-1, 0).EntireRow.Delete   c.Offset(0, 0).EntireRow.Delete   Set c = .FindNext(c)  '←ここからエラーとなってしまいます Loop While Not c Is Nothing And c.Address <> fAdd End If End With End Sub --- 「実行時エラー’1004’  Range クラスのFindNextプロパティを取得できません。」 とエラー表示されてしまいます。 --- 複数ある「"ああ"の行」の最上の1行だけにのみ実行されるだけです。 間違い箇所をご教示下さいませ。 よろしくお願い致します。

  • Excelでマクロ実行後、編集→置換をクリック→問題が発生!

    Windows XP Home Edition Excel 2002 下記1のマクロの実行後に必ず、 編集→置換をクリックしますと、画像の画面が出ます。 そしてExelを再起動すると、編集→置換をクリックしても問題なく使用できます。 しかし、再度、下記1のマクロを実行後、 ●編集→置換をクリック→画像の画面が出ます。 何回、行ってみても同じです。←このような事はよくあるのでしょうか? 下記1のマクロ自体は、正常に動作します。 しかし、 次の作業で、別のマクロを実行しますと、動作はするのですが、 下記2の一部のコードの「置換」が行われなくなります。 素通りしてしまいます。非常に困ります。 しかし、この「別のマクロ」に On Error Resume Next を追記すると  動作します(コードの「置換」も行われます)。  しかし、この直後も必ず、●編集→置換をクリック→画像の画面が出ます。 下記1の「いい」マクロだけを除いて実行するマクロは問題はありません。 ですから、次の作業で、下記2の一部のコード(置換)も、 On Error Resume Next を追記しなくても正常動作してくれます。 どうも、「下記1」の「いい」に問題があるように思いますが・・・ つなぎ合わせ過ぎでしょうか・・・ 原因がはっきり解かりませんが、ただ、今までに、マクロの実行作業中にあまり、 「編集→置換をクリック」の操作はしたこはないので、発覚することがなかったのかもしれません。 ●をなんとか解決できませんでしょうか? 参考:下記2の#DIV/0! #VALUE! は、数値以外の空白セル 、0 、文字等の為になります。    (これは直接的な原因ではないと思います) 何卒、よろしくお願い致します。   Call 下記1 Private Sub 下記1()   Call いい   Call うう   Call ええ   Call おお End Sub Private Sub いい() Dim i As Integer Dim nin As Range Windows("123.xls").Activate   Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1  For i = 1 To Worksheets.Count - 1  Worksheets(i).Activate  With Worksheets(i)   For Each nin In .Range("B4", .Range("B4").End(xlDown))   If nin.Cells.Value = 1 Then    nin.Offset(0, -1).Copy Cells(2, 6)   End If  Next nin End With   Call かか    Range("A23", Range("A23").End(xlDown)).Copy _    Destination:=Worksheets(Worksheets.Count).Range("IV3").End(xlToLeft).Offset(0, 1) Next i End Sub Private Sub かか() Dim fWord As Integer, fAdd, c   fWord = Cells(2, 6).Value    Range("L3").Copy Range("A23")  With Range("G:G")    Set c = .Find(fWord, LookIn:=xlValues, LookAt:=xlWhole)    If Not c Is Nothing Then     fAdd = c.Address     Do      c.Offset(0, 5).Copy      Range("A65536").End(xlUp). _      Offset(1, 0).PasteSpecial Paste:=xlAll, _       Transpose:=True      Set c = .FindNext(c)      Loop While Not c Is Nothing And c.Address <> fAdd     End If     Set c = Nothing  End With   '次に、同様にH列にも動作させる  With Range("H:H")    Set c = .Find(fWord, LookIn:=xlValues, LookAt:=xlWhole)    If Not c Is Nothing Then     fAdd = c.Address     Do     c.Offset(0, 4).Copy     Range("A65536").End(xlUp). _     Offset(1, 0).PasteSpecial Paste:=xlAll, _      Transpose:=True     Set c = .FindNext(c)     Loop While Not c Is Nothing And c.Address <> fAdd    End If     Set c = Nothing   End With End Sub ーーーーーーーーーーーーーーーーーーーーー '下記2   With Range(Range("A2").End(xlDown).Offset(3, 6), Range("A65536").End(xlUp).Offset(0, 25))    .Replace What:="#DIV/0!", Replacement:="0.0", LookAt:=xlPart, _     SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _     ReplaceFormat:=False    .Replace What:="#VALUE!", Replacement:="0.0", LookAt:=xlPart, _     SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _     ReplaceFormat:=False  End With

  • このコードの修正を、何卒よろしくお願い致します。

    EXEL 2002 です。 下記コードの修正を、何卒よろしくお願い致します。 ------ Sub コピー() Dim i As Integer For i = 1 To 2 Workbooks("コピー元.xls").Activate Worksheets(i).Range("A1", Range("C65536").End(xlUp).Offset(0, 168)).Copy _ Destination:=Workbooks("コピー先.xls").Worksheets(Workbooks("コピー先.xls").Sheets(1).Range("A1")) Next i End Sub

  • VBAの繰りかえし処理について

    workbook1(以下wb1)のB3に入力した県名を含む行を、 workbook2から取り出し、wb1のB7以降に表示させたいと思っています (ちなみに県名はwb2のC列に入っています) 同じ県名が含まれる行が多いので、それらを繰り返し処理で 全て書き出したいと思い、以下のマクロを作りました。 Sub macro3() Dim c Dim wb1 As Workbook Dim wb2 As Workbook Dim k As Integer Dim firstAddress As String Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("G:\zyouhousyori\inn100best_full.csv") Set c = cell.Find(What:=Range("B3").Value) With wb2.Worksheets(1).Range("A1:A100") If Not c Is Nothing Then firstAddress = c.Address Do Set c = cell.FindNext(c) For k = 0 To 10 .Range("C100").End(xlUp).Offset(1).Copy _ wb1.Worksheets("sheet1").Cells(7 + k, 2) Exit For ★Loop While Not c Is Nothing And _ c.Address <> firstAddress End If End With Application.ScreenUpdating = True wb2.Close False End Sub しかし、実行すると★マークのついた所でエラーになってしまいます (対応するDoがありません、と出ます) VBA初心者なので、どこがどう違うのかいまいちわかりません; アドバイスお願いします。

  • エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

    フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

  • 【VBA】複数のブックを1つのシートにまとめる

    あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。 フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。 (1)全て同じフォーマットである (2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい Sub 結合() '結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\" Const Fol As String = "C:\test\" Dim Fn Dim NewFile As Workbook Dim Wb As Workbook Dim Ws1 As Worksheet Dim R As Range Set NewFile = Workbooks.Add Set Ws1 = NewFile.Worksheets(1) Set R = Ws1.Range("A17") Fn = Dir(Fol, vbNormal) Do Until Fn = "" Set Wb = Workbooks.Open(Fol & Fn) 'ワークシート1をコピーする場合は Wb.Worksheets(1) Set Ws1 = Wb.Worksheets(1) 'タイトル行を設定 If ck = False Then For cnt = 1 To 4 Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1") Next cnt ck = True End If For cnt = 1 To 4 Set Ws1 = NewFile.Worksheets(cnt) Set Ws2 = Wb.Worksheets(cnt) R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1 With Ws2 End With Next 'A17行目からコピーして結合する(→本当はA17行目~K列までを反映したい) Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R If R.Offset(1).Value = "" Then Set R = R.Offset(1) Else Set R = R.End(xlDown).Offset(1) End If Wb.Close 'Debug.Print Fn Fn = Dir Loop Set R = Nothing Set Ws1 = Nothing: Set Ws2 = Nothing Set Wb = Nothing: Set NewFile = Nothing 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を最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub

  • 全部の列でSelection.NumberFormatLocal = "0.00"になってしまう

    以前こちらでお世話になった者です。 教えていただいたコードを応用したのですが、うまくいきません。 以下のようにすると、最後にすべての列の数値が0.00の形になってしまいます。 どこが悪いのか教えてください。よろしくお願いします。 Sub data_torikomi9_1() Dim wb As Workbook Dim Fn As String Dim myPath As String Dim dbBkSh As Worksheet Dim i As Long For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name And _ InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索 wb.Close '閉じる End If Next wb myPath = ThisWorkbook.Path & "\" Set dbBkSh = ThisWorkbook.Worksheets("様式9-1") With dbBkSh.UsedRange If .Cells(.Cells.Count).Row > 10 Then .Range("A11", .Cells(.Cells.Count)).Clear End If End With Fn = Dir(myPath & "form\*.xls") i = 1 '画面のちらつきを抑える Application.ScreenUpdating = False Do Until Fn = "" If Fn <> ThisWorkbook.Name Then With Workbooks.Open(myPath & "form\" & Fn, , True) '会社名と企業コード dbBkSh.Range("E2").Value = .Worksheets("inputform").Range("C2").Value dbBkSh.Range("B2").Value = .Worksheets("inputform").Range("M2").Value 'A11 - 1 dbBkSh.Range("A10").Offset(i, 0).Value = i 'B11 - 氏名 dbBkSh.Range("A10").Offset(i, 1).Value = .Worksheets("inputform").Range("C7").Value 'C11 - 番号 dbBkSh.Range("A10").Offset(i, 2).Value = .Worksheets("inputform").Range("H29").Value 'D11 - ポイント dbBkSh.Range("A10").Offset(i, 3).Value = .Worksheets("inputform").Range("H32").Value .Close False i = i + 1 End With End If Fn = Dir() Loop Columns("B:C").Select Selection.HorizontalAlignment = xlLeft Columns("C:C").Select Selection.NumberFormatLocal = "00000" Columns("A:A").Select Selection.HorizontalAlignment = xlCenter Columns("D:D").Select Selection.NumberFormatLocal = "0.00" Range("A6").Select Application.ScreenUpdating = True Set dbBkSh = Nothing End Sub

専門家に質問してみよう