• ベストアンサー

EXCEL VBA 文字 アドレス 検索 消去 セル

こんにちは。 EXCELの中にボタンを設置して以下のような動作をさせたいと思っておりますが、うまくいきません。 どのように改良すればよろしいでしょうか? 1.「end」の文字を検索し、そのセルのアドレスを取得する 2.取得したアドレスの行に関する値から一つ引いた値を計算で求める。例えばendがA10にあれば、A9とする 3.次にA3からA9までの範囲を消去する。 以下が自作したプログラムです。 Sub ボタン1_Click() Dim srcSheets As Worksheet Dim sinki As Integer sinki = MsgBox("データを消去しますか", vbYesNo) Select Case sinki Case vbYes '選択肢 Dim lngYLine As Long Dim intXLine As Integer Set Obj = Worksheets("Sheet2").Cells.Find("end") 'Sheet2の中でendを検索する。セルの場所を特定する。 If Obj Is Nothing Then MsgBox "endが見つかりません" Else lngYLine = Worksheets("Sheet2").Cells.Find("end").Row intXLine = Worksheets("Sheet2").Cells.Find("end").Column lngYLine = lngYLine - 1 End If With Sheets("Sheet2").Range("A3:intXLine+lngYLine").ClearContents End With End Select End Sub

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

  • ベストアンサー
  • o_chi_chi
  • ベストアンサー率45% (131/287)
回答No.2

#1です。 With End With もいらないですね。 というか使い方が間違ってます。 Sheets("Sheet2").Range(Cells(3,intXLine),Cells(lngYLine,intXLine)).ClearContents

defmerube
質問者

補足

早速の返事ありがとうございます。 ただ、アプリケーション定義またはオブジェクト定義のエラーです。 と表記されます。 以下のように改良しております。 Sub ボタン1_Click() Dim srcSheets As Worksheet Dim sinki As Integer sinki = MsgBox("データを消去しますか", vbYesNo) Select Case sinki Case vbYes 'データを削除 Dim lngYLine As Long Dim intXLine As Integer Set Obj = Worksheets("Sheet2").Cells.Find("end") 'endを検索する If Obj Is Nothing Then MsgBox "endが見つかりません" Else lngYLine = Obj.Row intXLine = Obj.Column lngYLine = lngYLine - 1 End If Sheets("Sheet2").Range(Cells(3, intXLine), Cells(lngYLine, intXLine)).ClearContents End Select End Sub

その他の回答 (4)

  • o_chi_chi
  • ベストアンサー率45% (131/287)
回答No.5

#1です。 endが見つからないときはクリアを実行してはいけないので Else (略) 'End If ←削除 Sheets("Sheet2").Range(Cells(3, intXLine), Cells(lngYLine, intXLine)).ClearContents End If '←追加 ですね。

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.4

そのエラーが出るということはコードの書き方が拙いのです。 それに、コードの書く場所も違います。 >End If >Sheets("Sheet2").Range(Cells(3, intXLine), Cells(lngYLine, intXLine)).ClearContents 上記2行を下記4行と入れ替えてください。    With Sheets("Sheet2")  .Range(.Cells(3, "A"), .Cells(lngYLine, intXLine)).ClearContents  End With  End If 値のクリアーは、必ず【A3】からendの前のセルまでですよね? 例えば、endが A7にあったら、A3~A6をクリアー C7にあったら、A3~C6をクリアー ということです。 また、 Range(.Cells(3, intXLine), .Cells(lngYLine, intXLine)) このようにすると、 endがC7にあったらクリアーされるのは、C3~C6になります。 以上。  

defmerube
質問者

お礼

分かりやすい解説ありがとうございます。 意図していたプログラムを作ることができました。 どうやら、 .Range(.Cells(3, "A"), .Cells(lngYLine, intXLine)).ClearContents の使い方が根本的にわかっていなかったようです。

  • nak777r
  • ベストアンサー率36% (49/136)
回答No.3

Set Obj = Worksheets("Sheet2").Cells.Find("end") Cells のFindメソッドは、該当したレンジを返しますので、 lngYLine = Worksheets("Sheet2").Cells.Find("end").Row intXLine = Worksheets("Sheet2").Cells.Find("end").Column lngYLine = lngYLine - 1 ここは、 lngYLine = Obj.Row intXLine = Obj.Column lngYLine = lngYLine - 1 でもいいですね

defmerube
質問者

お礼

簡略化のアドバイスありがとうございます。 こちらの方がすっきりして、見やすくなりました。 ぜひ、活用させていただきたいと思います!

  • o_chi_chi
  • ベストアンサー率45% (131/287)
回答No.1

With Sheets("Sheet2").Range(Cells(3,intXLine),Cells(lngYLine,intXLine)).ClearContents でいいのでは。 ちなみに sinki = MsgBox("データを消去しますか", vbYesNo) If sinki = vbNo then Exit Sub If Obj Is Nothing Then MsgBox "endが見つかりません" Set Obj = Nothing Exit Sub End If というふうにプロシージャを終了させるほうがわかりやすいと思います。

関連するQ&A

  • エクセルVBAのFINDの質問です。

    エクセルVBAのFINDの質問です。 シート1    A    B    C     D 1 コード1 コード2 コード3 名 称 2  4    1     1 3  4    2     2 4  4    3     1 シート2    A    B 1 コード1 名 称 2  1   名称1 3  2   名称2 やりたいことは、シート1のD列に、シート1のコード3をもとにシート2から名称を取得したいのです。 下記に記したプログラムだと最初のFINDNEXTは動くのですが、 2回目でエラーになってしまい、次を読んでくれません。 どなたか、ご教授頂けますでしょうか。 シート1の検索条件はコード1の"4"です。 シート1のコード1は重複キーで、一レコードずつ読んで行き、各レコード毎にシート2を読みたい のです。 Dim シート1 As Worksheet Dim シート2 As Worksheet Dim obj As Object Dim Lin As Integer Dim mykey As Integer Dim obj1 As Object Dim Lin1 As Integer Dim mykey1 As Integer Dim st_Lin As Integer Set シート1 = ThisWorkbook.Worksheets("シート1") Lin = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row mykey = "4" Set obj = シート1.Range("A1", "A" & Lin).Cells.Find(What:=mykey, _ LookIn:=xlValues, _ lookat:=xlWhole, _ SearchOrder:=xlByColumns) If obj Is Nothing Then   MsgBox ("異常です")   Exit Sub Else   st_Lin = obj.Row   Do Until obj.Row <> st_Lin    Set obj = シート1.Range("A1", "A" & Lin).FindNext(obj)    If obj Is Nothing Then     Exit Do    Else     Set シート2 = ThisWorkbook.Worksheets("シート2")       With シート2          Lin1 = .Cells(シート2.Rows.Count, 1).End(xlUp).Row          mykey1 = シート1.Cells(obj.Row, 3).Value          Set obj1 = .Range("A1", "A" & Lin1).Cells.Find          (What:=mykey1,LookIn:=xlValues,lookat:=xlWhole,SearchOrder:=xlByColumns)          If obj1 Is Nothing Then           MsgBox ("名称取得できませんでした")           Exit Sub          Else            シート1.Cells(obj.Row, 4).Value = .Cells(obj1.Row, 2).Value          End If       End With    End If   Loop End If

  • Excel VBAで検索(Win2000 Excel2000)

    現在、下記のようなコードを書いています。データテーブルの縦と横の検索値を探してその列数と行数を返したいのですが、下記の Sub検索1 と Sub検索2 を1つのSubで実行させるにはどうしたらよいのでしょうか?よろしくお願い致します。 ----------------------------------------- Sub 検索1() Worksheets("Data").Activate Dim x As Integer For x = 3 To 22 If Cells(2, x).Value >= 12 Then MsgBox x Exit Sub End If Next MsgBox "見つかりません" End Sub --------------------------------------------- Sub 検索2() Worksheets("Data").Activate Dim i As Integer For i = 4 To 42 If Cells(i, 2).Value = "A" Then MsgBox i Exit Sub End If Next MsgBox "見つかりません" End Sub

  • EXCELのVBAについて教えてください。

    演習1というシートの(1,1)のセルの値と(1,2)のセルの値を入れ替えるプログラムを作成したいので すがエラーが出て出来ません。コードは下記の様に書きました。 Sub 演習1() Dim sheetobj As Worksheet Dim a As Integer Set sheetobj = ThisWorkbook.Worksheets("演習1") With sheetobj a = .Cells(1, 1) .Cells(1, 1) = .Cells(1, 2) .Cells(1, 2) = a End With End Sub プログラミング自体が本を読んでも分かりません。 宜しければ小学生に教えるように文を訳してくれませんか?

  • エクセルVBAについて

    前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約120件になりSheet2においては、4倍になりますので約480件になります。 そこで Sheet1において12件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1~12がSheet2 Sh1 NO.13~24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか? お手数ですがよろしくお願いいたします。

  • 日付型変数を検索する方法

    シート内にある日付型の変数を検索させる処理をしたいのですが、以下のように記述したところ、 ================================== Dim hiduke As Date Dim lngYLine As Long Dim intXLine As Integer hiduke = Cells(1, 3).Value 'セルの値取得 Set Obj = Worksheets("Sheet1").Cells.Find(hiduke) If Obj Is Nothing Then MsgBox "該当の日付" & hiduke & "は、ありません。" Else lngYLine = Worksheets(newSh).Cells.Find(hiduke).Row intXLine = Worksheets(newSh).Cells.Find(hiduke).Column     MsgBox hiduke"は、" + CStr(lngYLine) + "行目の" _ + CStr(intXLine) + "列目にあります" End If ================================== Set Obj = Worksheets("Sheet1").Cells.Find(hiduke) で「実行時エラー"9" インデックスが有効範囲にありません」のエラーになります。 ワークブック内には Worksheets("Sheet1")存在しますし、なぜこのようなエラーがでるのか? また、どうしたら解消できるのか?について、教えていただきたく・・・ よろしくお願いいたします。

  • Excel VBA でExecuteExcel4Macro("GET.OBJECT(48,

    エクセル2000です。 以前、ワークシートに配置したフォームツールのラベルの参照元を取得するマクロをご教示いただき、以下のTest01は問題なく作動しています。 Sub test01() Dim obj As Object Dim i As Integer Dim obj_n As String 'オブジェクトの名前 With ActiveSheet For Each obj In .Labels i = i + 1 .Cells(i, 2) = obj.Name: obj_n = obj.Name .Cells(i, 3) = obj.TopLeftCell.Address 'GET.OBJECT で、リンクがないものを取ると、False になる .Cells(i, 5) = ExecuteExcel4Macro("GET.OBJECT(48,""" & obj_n & """)") .Cells(i, 6) = obj.OnAction Next End With End Sub 今回、同一シートではなく別シートに表示させようと以下のTest02を書いたのですが、やってみると .Cells(i, 5) はすべて#VALUE!エラーになってしまいました。 ExecuteExcel4Macro("GET.OBJECT(48~がどのようなものかわからずやっているので応用がききません。(そもそも48って?) どのようになおしたらよいのかご教示いただければ幸いです。 Sub test02() Dim obj As Object Dim i As Integer Dim obj_n As String Dim ws As Worksheet, ns As Worksheet Set ws = ActiveSheet Set ns = Worksheets.Add With ns For Each obj In ws.Labels i = i + 1 .Cells(i, 2) = obj.Name: obj_n = obj.Name .Cells(i, 3) = obj.TopLeftCell.Address .Cells(i, 5) = ExecuteExcel4Macro("GET.OBJECT(48,""" & obj_n & """)") .Cells(i, 6) = obj.OnAction Next End With End Sub

  • EXCEL VBAがうまく動きません。

    指定された rangeの中から2番目に小さい値を検索し、そのセルの行数を求めようとしていますが、えらーが出ます。いくつか試してみましたがだめでした。 初歩的な質問で恐縮ですが、教えてください。 構文は以下のように書きました。 Private Sub test() Dim s As Double Dim r As Range Dim secondsmall As range Dim smallrow as integer r = Worksheets("sheet1").Range("a1:a4") s = WorksheetFunction.Small(r, 2) secondsmall = WorksheetFunction.Find(what:=s) smallrow = secondsmall.row MsgBox smallrow end sub 宜しくお願いします。

  • Excel 文字列を検索して全て置換するマクロ

    当方VBA初心者なのですが、ExcelのVBAで作ったマクロでうまく動かなくて困っています。 もしおわかりになる方がいらっしゃったら是非よろしくお願いいたします。 *実現したいこと '”reference”という名前のシートに、次のようなデータが入っています。 (1) りんご (2) みかん (3) キウイ ・・・ これを、配列を2つ用意し、 (1)を配列Listに、(2)を配列List2へ格納して行きます。 '"data"という名前のシートには、A列の1~10行目までに文章が入っていて、 "家には、(1)があります。" "冬になるとよく(2)を食べます。" ・・・・ この全文をcというRangeに設定し、そのcの中において、 もし、配列1((1)等)のキーワードがあったら、 'そのキーワードを配列2(りんご等)の内容に書き換える。 'キーワードは、データシートに複数回出てくる場合もある。 *困っていること 下記のマクロだと、一度目のObjFindまでは成功するのですが、 List(i)を探しているはずが、2回目から、その変更後の文字列が含まれた全文を検索するようになってしまいます。 以下マクロです。 よろしくお願いいたします。 Sub TEST() Dim List() As String, List2() As String 'List Dim i As Integer Dim iRow As Integer iRow = Worksheets("reference").Cells(Rows.Count, 1).End(xlUp).Row ReDim List(iRow) ReDim List2(iRow) For i = 1 To iRow List(i) = Worksheets("reference").Cells(i, 1).Value List2(i) = Worksheets("reference").Cells(i, 2).Value Next i Dim lngYLine As Long Dim intXLine As Integer Dim objFind As Object Dim strAddress As String Dim strSamp As String Dim objRange As Range Dim c As Range For i = 1 To iRow Set objRange = Worksheets("data").Range("A1:A331") Set objFind = objRange.Cells.Find(List(i)) If Not objFind Is Nothing Then For Each c In objRange If c.Value = objFind Then lngYLine = objFind.Cells.Row intXLine = objFind.Cells.Column strSamp = Worksheets("data").Cells(lngYLine, 1) strSamp = Replace(strSamp, List(i), List2(i)) Worksheets("data").Cells(lngYLine, 1) = strSamp MsgBox List(i) + "は" + List2(i) + "に変更されました" Set objFind = Cells.FindNext(objFind) End If Next c Else MsgBox List(i) + "は見つかりませんでした" End If Next i End Sub

  • ExcelのVBAについて(勉強中のです。)

    ExcelのVBAについて(勉強中のです。) ここからコード3以降に入力したコードを抜き出してデータ表を作成しそれを保存するコードを作成したいです。例えばCSV形式にするとか? データ表は1日分の表示で、保存して週間や月間または統計データまでを視野にいれています。今回は保存する所です。。 利用しやすい状態と保存形式で、よろしくお願いします。データは生活記録みたいなものです。何したどうしたどうなった? ※大分分岐する予定で、作成中であり、今回はコードの整理は不要です。 '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Next i '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Activate End Sub

  • 課題制作で悩んでいます。 コンパイルエラー

    VBの初心者です。 課題制作で悩んでいます。 どうやら"obj"の部分が選択されているのでここが原因なんですが、宣言がされていないみたぃなのですがどうやって組みなおせば良いですか? Private Sub CommandButton3_Click() Dim lngYLine As Long Dim intXLine As Integer Dim objHit As Object Dim strFind As String '検索文字列の取得 strFind = 検索者氏名 Set obj = Worksheets("成績集計").Cells.Find(strFind) If obj Is Nothing Then MsgBox "見つかりませんでした。" Exit Sub Else '見つかった場所を取得 lngYLine = Worksheets("成績集計").Cells.Find("成績集計").Row intXLine = Worksheets("成績集計").Cells.Find("成績集計").Colum '見つかった場所を表示(テキストの場合) 検索結果.txt = 検索結果 & vbCrLf & CStr(lngYLine) + "行目の" & CStr(intXLine) & "列目" End If End Sub

専門家に質問してみよう