• 締切済み
  • すぐに回答を!

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初心者なので、どこがどう違うのかいまいちわかりません; アドバイスお願いします。

共感・応援の気持ちを伝えよう!

  • 回答数2
  • 閲覧数129
  • ありがとう数1

みんなの回答

  • 回答No.2

こういう問題はインデントを見ればわかります 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 _ このLoopと同じ高さにDoがあるはずですが、実際には1段低いところにあります。 Exit ForはForを閉じる文ではなく、Forから抜け出す文です ※修正案1   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    Next k   Loop While Not c Is Nothing And _ ただし、これだとForループを回らずに、1回通っただけで抜けてしまいます なので、 ※修正案2   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)    Next k   Loop While Not c Is Nothing And _ とすべきでしょう。 (プログラムの中身(動作)は見ていません)

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • エクセル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を使って検索をしたい

    VBAを使って検索をしたい EXCEL2007を使っております。 フォームを立ち上げて日付を入れるとシートの検索を行い、リスト内にその日付のA&#65374;Gまでのセルの内容が表示され、それらを別シートに貼り付けるといったことをしたいのですが、複数のセルの情報をリスト内に表示をするのが、よくわからず教えていただきたく思います。 フォーム内のテキストボックスに検索する日付を入れると 画像でいうところのA列を検索し、その日付内のA&#65374;Gをリストに表示して、ボタンを押すと貼り付けるといった、動きにしたいのですが、お願いします。 現状検索BOXに以下の記述をしてます これでは、A列のものだけが出てきます。お助けください。 ************************* Private Sub TextBox1_Change() Dim r As Range, FirstCell As Range, rng As Range Dim vnt As Variant Dim prow As Long Dim s As Worksheet Dim cnt As Long Set s = Sheets("sheet2") Set rng = Intersect(s.Range("a:a"), s.UsedRange) '検索キー Set r = rng.Find(What:=TextBox1.Text) If r Is Nothing Then MsgBox "見つかりませんよ" GoTo Exit_sub End If Set FirstCell = r ReDim vnt(0) vnt(0) = s.Cells(r.Row, 1).Resize(1, 5).Value '検索位置 prow = r.Row cnt = 1 Do Set r = rng.FindNext(r) If Not r Is Nothing And (r.Address <> FirstCell.Address) _ And (FirstCell.Row <> r.Row) And (prow <> r.Row) Then ReDim Preserve vnt(UBound(vnt) + 1) vnt(UBound(vnt)) = s.Cells(r.Row, 1).Resize(1, 5).Value '検索位置 prow = r.Row cnt = cnt + 1 End If Loop While r.Address <> FirstCell.Address ' If cnt = 1 Then vnt = s.Cells(FirstCell.Row, 1).Resize(1, 5).Value '検索位置 If cnt > 1 Then vnt = Application.Transpose(Application.Transpose(vnt)) ListBox1.List = vnt ' Set FirstCell = Nothing Erase vnt Exit_sub: If cnt = 0 Then ListBox1.Clear Set r = Nothing Set rng = Nothing Set s = Nothing 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

  • 回答No.1
  • nag0720
  • ベストアンサー率58% (1093/1860)

★の行の4行上にForがありますが、それに対応するNextがないのが原因です。

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • エクセルVBA条件セル検索時連続時処理中止と列複数

    いつもお世話になっております。 Excel2013のVBAでまた質問があります。お願いいたします。 ある表のにある値が入力されていたら、その値をコピーして1行上の4列右の列に貼り付け、もとの行の値を削除するように色々参考にしながら作りました。 ある値を例えば、"AAA”と"BBB"だとして、下記コードでなんとか最初の段階が実現できました。 あと、やりたいのは、条件を検索する列の、"AAA"もしくは"BBB"の値が連続している場合は、メッセージを出して、処理を中止にしたいです。単体で連続でも2つの組み合わせでも、この2つのうちいずれかが入力されている行が続いていたら中止です。 あと、最初にWorksheets("Sheet1").UsedRange.Columns(5)列目を指定しているんですが、実際は、複数の列を指定したいです。コピーしたり消去したりのオフセットの位置関係は変わりません。 必要なら、名前を定義して、一括で指定するのも大丈夫です。 お手数をおかけしますが、ご教授よろしくお願いいたします。 Sub TEST() Dim c As Range Dim firstAddress As String ' ActiveSheet.UsedRange.Select With Worksheets("Sheet1").UsedRange.Columns(5) Set c = .Find(What:="AAA", _ LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4) Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents Set c = .FindNext(c) If c Is Nothing Then Exit Do Loop Until c.Address = firstAddress End If '別条件でもう一度 Set c = .Find(What:="BBB", _ LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4) Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents Set c = .FindNext(c) If c Is Nothing Then Exit Do Loop Until c.Address = firstAddress End If End With End Sub

  • VBAのFindNextの使い方

    Excel2010でVBAでマクロを作ろうとしていますが、 FindNextで次検索をしても、一番上のセルだけしか検索できません。 どこかおかしな箇所はあるでしょうか… B列に「a」がある行のA列のセルに「b」を入力したいです。 B列には「a」があるセルは2セル以上あります。 ----------------------------------------------------- Dim a As Range Dim firstAddress As String With ActiveSheet.Range("B:B") Set a = .find("a", LookAt:=xlWhole) if Not a Is Nothing Then firstAddress = a.Address do Cells(a.Row, 1).Value = "b" a = .FindNext(a) Loop Until a.Address = firstAddrss End If End With -----------------------------------------------------

  • Excel vba 一度で全角・半角の文字を検索

    Excel vbaの初心者ですが、他のサイトを参考にして 以下のプログラムを作成しました。 指定された文字をシートから削除する物です。 「FindDelete」の中で、一度で全角・半角の文字を検索する方法があれば 教えてください。よろしくお願いします。 Sub FindDelete(ss As String) Dim FoundCell As Range Dim FirstCell As Range Dim Target As Range Dim c As Range Dim findArea As Range Set findArea = Intersect(Columns("E:F"), ActiveSheet.UsedRange) Set FoundCell = findArea.Find(What:=ss, LookAt:=xlPart) If FoundCell Is Nothing Then MsgBox ss & "は見つかりません" Exit Sub Else Set FirstCell = FoundCell Set Target = FoundCell End If Do Set FoundCell = findArea.FindNext(FoundCell) If FoundCell.Address = FirstCell.Address Then Exit Do Else Set Target = Union(Target, FoundCell) End If Loop Target.Select If MsgBox(ss & ":" & vbCrLf & Target.Count & "件見つかりました", vbYesNo, "削除しますか?") = vbYes Then For Each c In Target c = Replace(c, ss, "") Next c End If End Sub Sub tFindDelete() Dim ss As String ss = "カブシキガイシャ" ss = StrConv(ss, vbNarrow) FindDelete (ss) ss = StrConv(ss, vbWide) FindDelete (ss) ss = "ユウゲンガイシャ" ss = StrConv(ss, vbNarrow) FindDelete (ss) ss = StrConv(ss, vbWide) FindDelete (ss) End Sub

  • Excel VBA ループについて

    Excel VBA勉強中の者です。 シート名「一覧」のA列に入力されている「1」を検索し、メッセージボックスに表示させています。 現在、「1」はA3、A5、A7に入力されています。 下記のコードだとA3、A5、A7がメッセージボックスで表示された後、もう一度A3が表示されてしまいます。 A7が表示された時点で終わりにしたいのですが、どこを修正すればいいのでしょうか? Sub test() Dim xRange As Range Dim fPlace As String Dim i As Integer Dim xMoji As String xMoji = 1 Set xRange = Worksheets("一覧").Range("A1:A100").Find(What:=xMoji) If Not xRange Is Nothing Then fPlace = xRange.Address Msgbox xRange.Address Do   Set xRange = Worksheets("一覧").Range("A1:A100").FindNext(After:=xRange) If Not xRange Is Nothing Then   Msgbox xRange.Address End If Loop Until fPlace = xRange.Address End If End Sub よろしくお願いします。

  • エクセル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で他のbookのセルcellsで参照

    エクセルVBAで他のbookのセルの値(一定の範囲)を参照したいのですが、変数を使いたいため、cellsを使用したいのですがうまくいきません。方法はないでしょうか。 下記に例を示します。 rangeを使用すればすべてok((2)(5))(この場合はset文を使用しなくてもok(5))。同じbookならcells使用ok(4)。 他のbookをcells文使用する方法はないでしょうか(もちろんできれば、Thisbookの方もcellsを使用したい)。 よろしくお願いします。 sub test() Dim ThisBook As Workbook Dim Workbook2 As Workbook 'マクロを実行しているワークブック Set ThisBook = ThisWorkbook '他のワークブック Set Workbook2 = Workbooks("test11.xlsx") ' 'ThisBook.Worksheets(1).Range("A1:B2").Value = Workbook2.Worksheets(1).Range(Cells(1, 1), Cells(2, 2)).Value  '(1)だめ 'ThisBook.Worksheets(1).Range("A1:B2").Value = Workbook2.Worksheets(1).Range("a1:b2").Value '(2) OK 'Workbooks("test1.xlsm").Worksheets(1).Range("A1:B2").Value = Workbooks("test11.xlsx").Worksheets(1).Range(Cells(1, 1), Cells(2, 2)).Value '(3) だめ 'Workbooks("test1.xlsm").Worksheets(1).Range("A1:B2").Value = Workbooks("test1.xlsm").Worksheets(1).Range(Cells(3, 3), Cells(4, 4)).Value  '(4)だめ 'Workbooks("test1.xlsm").Worksheets(1).Range("A1:ii8000").Value = Workbooks("test11.xlsx").Worksheets(1).Range("a1:ii8000").Value  '(5) ok End Sub

  • 処理時間がかかりすぎます

    いろいろ調べながらマクロを書いたのですが時間がかかりすぎます。 どのうようにすれば時間短縮が図れるのでしょうか。 Sub sample() Dim tuki As Integer Dim bango As Integer Dim tukihi As Integer Dim c As Range For tuki = 1 To 12 For bango = 11 To 1000 For tukihi = 14 To 19 With Worksheets(Format(tuki) & "月").UsedRange.Rows(3) Set c = .Find(what:=Worksheets("年間予定表").Cells(bango, tukihi).Value, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then Worksheets("年間予定表").Range("N1") = c.Address Worksheets(Format(tuki) & "月").Range(c.Address).Offset(bango - 3, 0) = _ Worksheets("年間予定表").Cells(bango, 3).Value & _ Worksheets("年間予定表").Cells(bango, 2).Value & _ " , " _ & Worksheets("年間予定表").Cells(bango, 21).Value End If End With Next tukihi Next bango Next tuki End Sub Sub youbi_s

  • エクセルVBAで別BOOKに「名前の定義」のCopy

    前からあったエクセルのファイルのどこかが壊れたらしく、ときどき作業中に突然エラーとなってエクセル自体が落ちてしまうので、BOOKの複製では意味がないと考え、同じ内容のものを別BOOKに再作成するマクロを以下のとおり作ってみました。(新規作成のBOOKにこのマクロを貼ります) これで、VBAのモジュールを除き、再作成できたのですが、どういうわけか「名前の定義」を行なったセル範囲の一部が反映されません。 調べてみると、他のセルから参照されていない「名前の定義」がすっぽり抜け落ちるようにも思えるのですが、この理解であっているでしょうか? 他のセルから参照していなくとも、マクロで参照しているので抜け落ちるのは困ります。 どうすれば、すべての「名前の定義」が再作成されるでしょうか? Sub Book_Copy() Dim fn As String Dim wb1 As Workbook, wb2 As Workbook Dim ans As Integer, i As Integer Dim nm As Name Dim sh As Worksheet fn = Application.GetOpenFilename("エクセル ファイル (*.xls), *.xls") If fn = "False" Then Exit Sub Application.EnableEvents = False Set wb1 = Workbooks.Open(Filename:=fn, UpdateLinks:=1) Set wb2 = ThisWorkbook ans = MsgBox(wb1.Name & "を " & wb2.Name & " へCopyしますか?", vbYesNo + vbQuestion) If ans = vbNo Then Exit Sub For Each nm In wb2.Names nm.Delete Next nm For Each sh In wb1.Worksheets sh.Cells.Copy i = i + 1 If wb2.Worksheets.Count = i Then wb2.Worksheets.Add After:=Worksheets(i) Application.DisplayAlerts = False wb2.Activate wb2.Worksheets(i).Activate wb2.Worksheets(i).Cells.Select ActiveSheet.Paste wb2.Worksheets(i).Name = sh.Name Application.DisplayAlerts = True Application.CutCopyMode = False End If Next sh wb1.Close (False) Application.EnableEvents = True ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks Set wb1 = Nothing Set wb2 = Nothing End Sub

  • EXCEL2010エラーVBA

    下記を実行するとエラーになりEXCEL2010が終了してしまいます。 fDebug:0 offset00009391 がエラーメッセージです。 何が原因でしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim rg As Range Dim r As Variant Dim c As Long Dim hanni1 As Range Dim atai As Range Set ws = Worksheets("あああ") Set rg = Worksheets("コード").Range("A1:B10") r = ws.Cells(Rows.Count, 1).End(xlUp).Row Set hanni1 = ws.Range(Cells(2, 2), Cells(r, 3)) Set atai = ws.Range(Cells(2, 3), Cells(r, 3)) atai = Application.VLookup(hanni1, rg, 2, False) End Sub

  • エクセル VBA

    A1,A2,A3→RAND()*99+1 B1→MAX(A1:A3) Sub test() Worksheets("sheet1").Calculate Dim x As Integer x = Range("B1") Range("C1").Value = x End Sub このように記述すると、B2とC2で結果が変わってしまうのですが、どうしてでしょうか?結果を同じにするにはどうすればいいですか?