• 締切済み
  • 困ってます

【VBA】Ifで他シートから検索しコピーする

Excel vbaについて教えてください。 自分で作成したコードが、うまく動かず悩んでいます。 ●作りたいもの Sheet3のA列にある数字を検索値とし、 Sheet1のA列を検索し、合致する行のB列~最終列までコピーし、 Sheet3のB列から貼付する。 ※Sheet1にある列数(項目数)は不定です ●作成したマクロ Sub test() Dim sh1 As WorkSheet Dim sh2 As WorkSheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet3") d = sh2.Range("A1").End(xlDown).Row 'Sheet3検索値のA列のデータの最終行 g = sh1.Range("B1").End(xlToRight).Column 'Sheet1の最終列 k = 2 For i = 2 To d    'Sheet3最終行まで If sh1.Cells( i & "A") = sh2.Cells( 1,"A") Then '条件)Sheet1とSheet3のA列が合致 For j = 2 To g                      'Sheet1の最終列まで sh2.Cells( k , j ) = sh1.Cells( i , j ) 'Sheet1のB行から最終列をコピーしSheet3へ貼付 Next j End If Next End Sub いろいろ直していたのですが、Set sh2 = Worksheets("Sheet3")で「インデックスが有効範囲にありません」(同じブック内に同名シートがあるのに?)とエラーが出たり、 また、B行から最終列までコピーする際の範囲指定についてもよくわからず、 もっと他に良い方法が無いものかとお手上げ状態です。 どうぞ宜しくお願いいたします。

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

  • 回答数1
  • 閲覧数3645
  • ありがとう数0

みんなの回答

  • 回答No.1
noname#203218

下記のような事で良いでしょうか。 1.シート3のセルA1データでシート1のA2以降最終行までの検索を行い。 2.シート1の検索した行のB列から最終列のデータをシート3のB2の行にデータ入力 シート1のデータの列数が全て同数なのか不明なので、最大列数の検索は、データ検索後にする事にしています。 検索結果が一致しない場合はエラーメッセージを表示します。 意図する物違う場合は、手直し下さい。 Sub test() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim d, i, j, k As Integer Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet3") g = 0 d = sh1.Range("A1").End(xlDown).Row k = 2 For i = 2 To d 'シート3のセルA1の値とシート1、A列の値が同一行を検索 If sh1.Cells(i, 1) = sh2.Cells(1, 1) Then g = sh1.Range("B" & i).End(xlToRight).Column For j = 2 To g sh2.Cells(k, j) = sh1.Cells(i, j) Next j Exit For End If Next If g = 0 Then MsgBox "一致するデータは有りませんでした。シート3のA1データを確認して下さい。" End Sub

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

質問者からの補足

ご回答いただき、ありがとうございます。 いただいた回答を試す環境が会社にしかなく、返答が遅くなってしまい申し訳ありませんでした。 補足ですが、 >シート1のデータの列数が全て同数なのか不明なので シート1のデータ列数はすべて同数です。 早速試しましたところ、 シート3のA列の検索値に一致するものが、シート1の検索範囲にあるにも関わらず「一致するデータなし」とメッセージが出た為、以下を修正しました。 If sh1.Cells(i, 1) = sh2.Cells(1, 1) Then → If sh1.Cells(1, i) = sh2.Cells(1, i) Then その結果、添付いただいた画像通りになりましたが、 シート3のA列1行目で検索が終わってしまうようでした。 検索値が複数ある場合を想定して、 シート3のA列にある検索値をA1から下まで行うにはどうすればよいでしょうか? 別案として、 g = sh2.Range("B1").End(xlToRight).Column r = 1 Do While sh2.Range("A" & r ).Value<>"" Set f = sh2.Columns("A").Find sh2.Range("A"& r ).Value, LookAt:=xlWhole, LookIn:=xlValues If Not f Is Nothing Then Sheet3.Cells( g , r).Value = Sheet1.Cells( g , f).Value End If r = r + 1 Loop というのも考えたのですが、 Sheet3.Cells( g , r).Value = Sheet1.Cells( g , f).Value セル設定が間違えているようで、ここでRangeオブジェクト?のエラーが出てしまいます。 もしよろしければ修正点を教えていただけないでしょうか。

関連するQ&A

  • ExcelVBAで画像の様に動作を変更したいです

    先日、こちらにて 教えていただいたマクロでのデータ突合方法を基にマクロを作成中なのですが、 画像の様に動作させるにはどう修正すればよいでしょうか (目標) 画像のSheet1 と Sheet2の商品コードを上から順に突合し、 Sheet3に合致したA品番をコピー Sheet4に合致したB品番をコピー Sheet5に合致しなかったA品番をコピー Sheet6に合致しなかったB品番をコピー ※なお、A品番B品番ともに同じ値の品番がいくつか存在することがある。 この場合は、ループ中既に合致したデータは対象から外す。 判別方法は品番の一つ横のセルに”〇”を表記。(フラグを立てる) 「A品番=B品番」のとき「Offset(0, 1)が”〇”」ならば合致しない  --------------------------------------------------- (手順) (1)Sheet1 あり Sheet2 ありの場合 →一致したSheet1とSheet2のOffset(0, 1)に”〇” →一致したSheet1の行全体の値をSheet3にコピー →一致したSheet2の行全体の値をSheet4にコピー (2)Sheet1 あり Sheet2 なしの場合 →該当するSheet1の行全体の値をSheet5にコピー (3)Sheet1 なし Sheet2 ありの場合 →該当するSheet2の行全体の値をSheet6にコピー --------------------------------------------------- (現在のコード) Sub Test() Dim c As Range, FRange As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp)) Set FRange = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)). _ Find(c.Value, LookAt:=xlWhole, After:=Sh2.Cells(Rows.Count, "A").End(xlUp)) If Not FRange Is Nothing Then If c.Value = FRange.Value And FRange.Offset(1, 0).Value <> "◯" Then c.Offset(0, 1).Value = "◯" '↓(1).xlsmSheet2に Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value FRange.Offset(0, 1).Value = "◯" End If Else '↓(1).xlsmのSheet3に Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next For Each c In Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)) If c.Offset(0, 1).Value = "◯" Then '↓(2).xlsmのSheet2に Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value Else '↓(2).xlsmのSheet3に Sheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next End Sub ご指導頂ければ幸いです。

  • エクセル2000VBA 情報の検索について

    いつもお世話になります。 sheet1は商品情報検索画面で、sheet2は、データのマスターです。 sheet1のセル"D4"に商品コードを入力し、マクロを起動することで、sheet2の商品コード(A列)の同じ情報を検索し、その次のセルの商品コードを表示させたいのです。(ややこしくてすみません) 自分なりに考えてコードを作ってみたのですが・・・ Dim sh2, sh3 As Worksheet Dim temp As Variant Set sh2 = Worksheets("sheet2") Set sh3 = Worksheets("sheet1") d = sh2.Range("A1").CurrentRegion.Rows.Count Set temp = sh2.Range("A2:A" & d).Find(What:=sh3.Range("D4").Value) For l = 2 To d If Not temp Is Nothing Then sh3.Range("D4").Value = sh2.Cells(l, 1).Offset(1, 0).Value ElseIf temp Is Nothing Then sh3.Range("D4").Value = sh2.Range("A2").Value End If Next l 以上だと、次々に情報が更新され、結局最終行の空白が答えになってしまいます。 以上宜しくお願い致します。

  • VBA 条件検索について

    VBAの検索について質問です。 以下のようなものを作ろうと思います。 sheet1とsheet2がありsheet1のA、Bの数値をsheet2の同じA,Bの数値の値の行を検索して, その同じ値の行のsheet1のCの数値の値からsheet2のCの数値を引いた値をsheet3のC列に返すプログラムを作ろうと思います。空白などで同じ値がない場合はsheet3に空欄を返そうと思います。 以下に例をプログラムの実行例を示します。 sheet1 ■ A 列 B 列 C列 1: 7 | 1 | 3 2: 5 | 8 | 2 3: 2 | 3 | 1 4: 9 | 6 | 4 sheet2 ■ A 列 B列 C列 1: 2 | 3 | 4 2: 9 | 6 | 2 3: 7 | 1 | 5 4: 5|   | 3 sheet3 ■ A列 B列 C列 1: 7| 1 | -2 2: 3: 2| 3 | -3 4: 9 | 6 | 2 自分で以下のプログラムを作成してみたのですが空欄が検索できなかったりしてなかなかできません。 どなたか、教えてください。お願いします。 Sub test() Dim sh1 As Object, sh2 As Object, sh3 As Object Dim d1 As String, d2 As String, a As Long Set sh1 =Sheets(“Sheet1”) Set sh2 =Sheets(“Sheet2”) Set sh3 =Sheets(“Sheet3”) For a = 1 To 3000 Step 1 d1 = sh1.Cells(a,1) & sh1.Cells(a,2) d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Do while d2 <>”” If d1 = d2 Then Sh3.Cells(a,1) = sh1.Cells(a,1) Sh3.Cells(a,2) = sh1.Cells(a,2) Sh3.Cells(a,3) = sh1.Cells(a,3) Exit Do End If a= a+1 d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Loop Next End Sub

  • 【エクセルVBA】特定のシートのみ検索したい

    VBA勉強中です。 フォルダにある複数のファイル(1ファイル内には複数シートあります)を順番に開けて検索をかけ、条件に合致した行をあるファイルへ転記・集約させるマクロを組みたいと思っています。 (条件は1番左の列が「○」であることです。) ネットや本を参考にしながら組んでみたのですが、「○」がない(シートの)行も転記されてしまい困っています。 (○があるシートは複数シートの内、1シートのみなのですが、○がないシートからも 「○があるシートの○がある行」と同じ行番号の行がが転記されているようです) 組んでみたマクロは以下のとおりです。 ------------------------------------------------ Sub 楕円1_Click() ActiveSheet.Range("A2:H30").ClearContents Dim ans, fn, wb, x, i, n, sh, myPath ans = "○" '条件 myPath = ThisWorkbook.Path & "\" fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイル Do Until fn = "" If fn <> ThisWorkbook.Name Then 'ファイルが当ファイル以外なら Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開きます For Each sh In wb.Worksheets '各シートごとに x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得 For i = 1 To x '1行目から最終行まで以下を実行します If Cells(i, 1) = ans Then '条件に合致するか検索 n = n + 1 With ThisWorkbook.Sheets("Sheet1") '転記 .Cells(n + 1, 1) = sh.Cells(i, "B") .Cells(n + 1, 2) = sh.Cells(i, "C") .Cells(n + 1, 3) = sh.Cells(i, "D") .Cells(n + 1, 4) = sh.Cells(i, "E") .Cells(n + 1, 5) = sh.Cells(i, "F") End With End If Next i Next sh wb.Close (False) '選択したファイルを閉じる End If fn = Dir() '次のファイルを検索 Set wb = Nothing Loop '繰り返し --------------------------------------------------------- このマクロでは各ファイルの全てのシートを検索していると思うのですが、 全シートを検索していることが問題でしょうか? 検索したいデータは特定のシートにのみ存在するので(全ファイル同じ名前のシートです) 特定のシートのみ検索してくれればそれで良いのですがどう変更すればよいかわかりません。 「For Each sh In wb.Worksheets '各シートごとに」 色々と調べてここを変更してみたのですが 何れもエラーとなり上手くいきませんでした。 どなたか上手く直す方法を教えて下さい。 宜しくお願いします。

  • VBA 別シートの最終行に追記

    ExcelのSheet1で作成した表の一部項目を、Sheet2に一覧表としてまとめたいのです。 例えばSheet1にアンケート項目のような入力されていて、毎日使いまわします。 セルA1: 訪問日→固定     セルB1: (日付)→更新 セルA3: お客様指名→固定  セルB3: (氏名)→更新 使いまわすので、1度入力されたものは、Sheet2に一覧表として転記しておきたいのです。Sheet2の一覧表の最終行をみつけて追記していきたいです。 書いてみたのは以下の通り。 Private Sub 登録ボタン_Click() Dim SH1 As Worksheet, SH2 As Worksheet Dim GYO As Long Set SH1 = ThisWorkbook.Worksheets("回答内容") Set SH2 = ThisWorkbook.Worksheets("情報シート") ' Sheet2の最終行を取得 GYO = SH2.Range("$A$65536").End(xlUp).Row ' 最終行の次行を取得 If SH2.Cells(GYO, 1).Value <> "" Then GYO = GYO + 1  ' 現在の収容位置の下に転記 SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$c$2:$D$10").Value With SH1 .Range("A3").Copy Destination:=SH2.Range("A2") .Range("B3").Copy Destination:=SH2.Range("B2") End With End Sub 項目は飛び飛びのセルに入力されていて、それらをまとめて一覧表の1行にまとめたいと思っています。 ここでは例としてSheet1[A3][B3]セルをSheet2へ転記していますが、項目はもっといっぱいあります。 記載したコードで実行すると、1回目は転記されますが、2回目以降が追記されていきません。 ' 現在の収容位置の下に転記 のところに問題があると思っています。 全くの初心者が、コードを書くのには無理があると思いますが、どなたか教えていただけないでしょうか。宜しくお願いします。

  • VBAの複数条件分岐について

    VBAで下記の構文を使用してシート1にある表より 条件に合致するもののみシート2に抽出するようにしています。 現在はシート1のE2セルの値がシート1のB列の値と比較して 該当するものを抽出しています。 この条件が、 シート1のE1のセルの値が20より小さい場合、 かつE2のセルの値がシート1のB列の値と比較して該当するものを シート1に貼り付け、 シート1のE1のセルの値が20以上の場合、 かつE2のセルの値がシート1のD列の値と比較して該当するものを シート1に貼り付ける というような条件に変えたいのですが どのように変更したらよろしいのでしょうか。 よろしくご教授下さい。 ちなみに現在使用している構文です。 これもきれいな構文かはわからないのですが・・・ Sub test() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") k = 1 sh2.Cells(k, "B") = sh1.Cells(1, "A") sh2.Cells(k, "C") = sh1.Cells(1, "B") k = k + 1 d = sh1.Range("A65536").End(xlUp).Row For i = 2 To d If sh1.Cells(i, "B") <= sh1.Range("E2") Then sh2.Cells(k, "B") = sh1.Cells(i, "A") sh2.Cells(k, "C") = sh1.Cells(i, "B") k = k + 1 End If Next i sh2.Activate End Sub

  • EXCEL VBA 文字列検索とコピー

    以前にも同じ質問をさせて頂いたのですが、どうも上手くいかないので今一度お願い致します! 名簿を作成していて、現在下記のようなシートになっています。 [ Sheet1 ] A   B   C   D   E   F   G   H 日付 ○  ○  ○  ○  名前 電話 メール このF列の名前を検索して、検索文字に該当する全てのセルの行ごと(出きればA1:H2の範囲)コピーして、Sheet2に貼り付けたいです。 現在のコードは、以下のようになってます。 宜しくお願いします!! Sub 検索1() Dim myFind As Variant Dim myfRow As Long, c As Range Dim CopySh As Worksheet Dim i As Long Dim num As Integer Set CopySh = Worksheets("Sheet2") 'コピー先のセルの最初の行 i = 1 '================================== myFind = Application.InputBox("検索文字をカナで入力してください", Type:=2) If VarType(myFind) = vbBoolean Or myFind = "" Then Exit Sub With Worksheets("Sheet1").Cells(4.4) Set c = .Find(myFind, , xlValues, xlWhole) If Not c Is Nothing Then myfRow = c.Row Do c.Copy CopySh.Cells(i, 1) 'コピー Set c = .FindNext(c) i = i + 1 Loop Until c Is Nothing Or myfRow = c.Row End If End With Beep '終了の合図

  • Excel VBA元データから別シートへ振り分け

    元データ(DB)をA列の値で振り分け 別シート(印刷)に転記していく方法について教えてください。 以下のコードで転記は行えましたが1つの値で1つのシートを作成になってしまいます。 どこをどのように変更すればA列の値(一種類に1つのシートにまとめたい)に 1つのシートに転記となるかご教示お願いします。 Sub test01() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("DB") Set sh2 = Worksheets("印刷") d = sh1.Range("A65536").End(xlUp).Row For i = 2 To d sh2.Cells(6, "B") = sh1.Cells(i, "A") sh2.Cells(10, "B") = sh1.Cells(i, "B") sh2.Cells(10, "C") = sh1.Cells(i, "C") sh2.Cells(10, "D") = sh1.Cells(i, "D") sh2.Cells(10, "E") = sh1.Cells(i, "E") sh2.Cells(10, "F") = sh1.Cells(i, "F") sh2.Cells(10, "G") = sh1.Cells(i, "G") sh2.Cells(10, "H") = sh1.Cells(i, "H") sh2.Cells(10, "J") = sh1.Cells(i, "I") 'sh2.Range("a1:J34").PrintOut Next i End Sub よろしくお願いいたします。

  • VBAで検索してコピー

    エクセル2003を使っています。 下記のような構文で、あるデータを検索しています。 検索まではできましたが、その検索したデータが入力されている行を選択して別のシートにコピーしたいです。 Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet Dim rng As Range Set ws1 = Sheets("CSV") '検索先のシート Set ws2 = Sheets("0群加工") '検索データのシート Set ws3 = Sheets("完了") '貼付先シート Set ws4 = Sheets("過程") With ws1.Columns("A") '完全一致でシートの頭から検索(A列) i = 2 Do Until ws2.Cells(i, "E").Value = "" 'ws2のデータがなくなるまで Set rng = .Find(What:=ws2.Cells(i, "E").Value, LookAt:=xlPart, After:=.Cells(.Cells.Count)) '検索 上記は0群加工シートに入力されているデータを、CSVシートに入力されているデータを検索しています。 (ここのデータというのは時間が入力されています。つまり、0群シートに入力されている時間と同じ時間を、CSVシートで検索しています) CSVシートに同じデータがあれば、そのデータがあるセルが属する行をコピーして、違うシートに貼り付けたいです。 よろしくお願いします。

  • Excel VBAで検索結果を新規ブックにコピー

    Excel VBAの質問です。 コンボボックスで選択した文字列とSheet1のC列の文字列が一致したら、 その行を新規ブックのSheet1にコピーしたいのですが、うまくできません。 新規ブックは開くのですが、データはコピーされていません。 既存ブックのSheet2にはコピーできるので、たぶん、新規ブックのSheet1へコピーという 命令がうまくかけていないのだと思います。 書籍やネットで調べてもよく分かりませんでした。 大変困っているので、どなたかご教授ください。よろしくお願いします。 元のSheet1は以下のようにデータが入力されています。 例えば、コンボボックスで「めがね」と選択されたら、1,4,5行目のC列と一致するので それらの行を新規ブックにコピーしたいのです。 A B C D ----------------------------- 1|10 10:00 めがね 保管中 2|11 12:00 衣服  倉庫 3|12 13:00 自転車 保管中 4|13 11:00 めがね 保管中 5|14 13:00 めがね 倉庫 Private Sub Search_Click() Dim SearchWord As String Dim gyou As Long Dim word As String Dim LastRow As Long Dim count As Integer Dim baseBook As Workbook Dim newBook As Workbook Dim baseSheet As Worksheet Dim newSheet As Worksheet SearchWord = cmbsSyutokubutu_search.Text Set baseBook = ThisWorkbook Set baseSheet = baseB.Worksheets("Sheet1") baseSheet.Activate With Worksheets("Sheet1") count = 0 gyou = 4 LastRow = baseSheet.Cells(Rows.count, 5).End(xlUp).Row Set newB = Workbooks.Add Set newS = newBook.Worksheets("Sheet1") Do While Cells(gyou, 3) <> "" word = Cells(gyou, 3) If InStr(word, SearchWord) >= 1 Then Rows(gyou).Copy newBook.Cells(Rows.count, 1).End(xlUp).Offset(1, 0) End If gyou = gyou + 1 Loop End With End Sub