[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『指定した値を検索し、別エクセルに転記したい』（SS）
閲覧ありがとうございます。
内容
A列に3～4桁の数字が記入されており、
そこから指定した数字を検索。
指定の数字がある行のセルＤの内容を別のエクセルへコピペ。
この処理を検索条件を変えて繰り返したい。
現状は下記の通り値をを検索せず必要な列をまとめてコピペしています。
ここに検索条件を変えながら繰り返し処理を行いたいです。
A列の1000の値を検索→1000の値があるD列のセルを別のエクセルにコピペ
→1234の値を…以下略
検索する値は事前に決まっています。
複数条件を指定した繰り返し処理のやり方がわからないため、どなたか教えていただけますと幸いです。
Sub マスターデータ取込02() '選択したファイルを取り込み、別のファイルに貼り付ける。
Dim RC As Integer
Dim OpenFileName, fileName, Path, SetFile As String
Dim wbMoto, wbSaki As Workbook
Dim lr As Long
Set wbMoto = ActiveWorkbook 'マスターデータ取り込み元をセット
Application.DisplayAlerts = False
RC = MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認")
If RC = vbYes Then
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
If OpenFileName <> "False" Then
SetFile = OpenFileName
Else
MsgBox "キャンセルされました"
Exit Sub 'マスターデータの取り込みをキャンセル
End If
Workbooks.Open fileName:=SetFile, ReadOnly:=True, UpdateLinks:=0
Set wbSaki = Workbooks.Open(Path & SetFile)
lr = Cells(Rows.Count, 1).End(xlUp).Row
'ワークブック間のシート「全得意先」をコピーします。
wbSaki.Worksheets("全得意先").Range("D1:D & lr").Copy
wbMoto.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False 'コピー切り取りを解除
wbSaki.Close False 'マスターデータ取り込み先のファイルを閉じる
Else
MsgBox "処理を中断します"
End If
Application.DisplayAlerts = True
End Sub
'
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
これだけのコードが書けて繰り返しがわからいとは少しアンバランスな気もしますが、、 いきなりBook間でしないで最初はシート内を想定して記録してみてはいかがですか？ （SoulMan） 2021/04/03(土) 11:48
とりあえず毎回のツッコミ
★１ saki と moto なんか意味が逆だと思います。
★２ Workbooks.Open fileName:=SetFile, ReadOnly:=True, UpdateLinks:=0 Set wbSaki = Workbooks.Open(Path & SetFile)
↑（おそらく）同じブックを開くことなっちゃいますので無駄です。
★３ Dim wbMoto, wbSaki As Workbook Dim OpenFileName, fileName, Path, SetFile As String ↑のように書くと、型指定は最後のものしか対象になりません。 （他はVariant型になります）
上記は、参考にされたかもしれないトピックにも書いてあります。
質問のほうは
(1)「wbSaki」になるはずのブックを開く (2)「wbSaki」の対象シートにオートフィルタを設定する (3)「wbSaki」の対象シートにオートフィルタを操作してA列が"1000"であるものを抽出する (4)「wbSaki」の対象シートにオートフィルタが設定されている範囲のうちD列をコピーする (5) "別のエクセル"に貼付けする (3)～(5)を繰り返す (6)「wbSaki」を閉じる
というアプローチを考えてみてはどうでしょうか？
繰り返しの部分が分からなければとりあえず「1000」であるものをコピペすること"だけ"考えてみましょう。
提示されたコードと既に提案案されている「マクロの記録」を使えば、たたき台となるコードが得られると思いますので。まずはそれを提示してみてください。
（もこな２） 2021/04/03(土) 12:35
SoulMan様 もこな2様
ご回答いただきありがとうございます。
ご指摘いただいた点をまずは試してみます。
（SS） 2021/04/03(土) 14:22
商品番号を取得し
Sub マスターデータ取込03()
Dim RC As Integer
Dim OpenFileName, SetFile As String
Dim wbMoto As Workbook, wbSaki As Workbook
Dim lr As Long
Set wbSaki = ActiveWorkbook 'マスターデータ取り込み元をセット"
Columns(5).Insert
If Range("E1") = "" Then
Range("E1").Value = Date
End If
Application.DisplayAlerts = False
RC = MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認")
If RC = vbYes Then
If OpenFileName <> "False" Then
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
Else
MsgBox "キャンセルされました"
Exit Sub 'マスターデータの取り込みをキャンセル
End If
lr = Cells(Rows.Count, 1).End(xlUp).Row - 2
lr1 = Cells(Rows.Count, "E").End(xlUp).Row
SetFile = OpenFileName
Set wbMoto = Workbooks.Open(SetFile)
'↓の内容を繰り返す
wbMoto.Worksheets("全得意先").Range("A1:AC" & lr).AutoFilter Field:=4, Criteria1:="1420"'←この数字を変えて繰り返し処理する
Range("AC1").End(xlDown).Copy
wbSaki.Worksheets("売上").Range("E" & lr1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False 'コピー切り取りを解除
wbMoto.Worksheets("全得意先").Range("A1:AC" & lr).AutoFilter
wbMoto.Close True
Else
MsgBox "処理を中断します"
End If
Application.DisplayAlerts = True
End Sub
（SS） 2021/04/05(月) 22:29
lr = Cells(Rows.Count, 1).End(xlUp).Row - 2 lr1 = Cells(Rows.Count, "E").End(xlUp).Row
↑のような書き方だと、ActiveSheetが対象になっちゃいますよ。
↓のようにしてるので、それぞれ別のシートで求めるべきことなんじゃないですか？
wbMoto.Worksheets("全得意先").Range("A1:AC" & lr).AutoFilter
wbSaki.Worksheets("売上").Range("E" & lr1 + 1)
■２
＞"1420" "1769" "1829"...等法則性のない数字になります。
それはどこかに書いてある（リストアップされている）のですか？
■３
見づらかったのでちょっと整理してみました。
気になるところにコメントを書きましたので読んでみてください。
Sub マスターデータ取込03_整理()
Dim wbMoto As Workbook, wbSaki As Workbook
Dim lr As Long, lr1 As Long '「lr1」もちゃんと宣言すべき
Dim OpenFileName As String
'▼処理するのか確認する
If MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
'▼ダイアログボックスで「wbMoto」になるブックのパスを取得する
If OpenFileName <> "False" Then
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
Else
MsgBox "キャンセルされました"
Exit Sub
End If
Else
MsgBox "処理を中断します"
Exit Sub
End If
'▼よくわかりませんが必要なら修正
With ActiveSheet
lr = .Cells(.Rows.Count, 1).End(xlUp).Row - 2 '←ちゃんとシートを指定すべき
lr1 = .Cells(.Rows.Count, "E").End(xlUp).Row '←ちゃんとシートを指定すべき
End With
'▼それぞれ取得（"元"なのか"先"なのかよくわからないので必要なら修正）
Set wbSaki = ActiveWorkbook
Set wbMoto = Workbooks.Open(OpenFileName)
'----▼▼▼-----ここから繰り返す----▼▼▼-----
'▼抽出を実行
wbMoto.Worksheets("全得意先").Range("A1:AC1").AutoFilter Field:=4, Criteria1:="1420"
'▼コピペ
wbMoto.Worksheets("全得意先").Range("AC1").End(xlDown).Copy
With wbSaki.Worksheets("売上")
.Cells(.Rows.Count, "E").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
'----▲▲▲-----ここまで繰り返す----▲▲▲-----
wbMoto.Close False '←データ元側は何もしてないから保存する必要ないのでは？（保存しないならいちいちオートフィルタを解除する必要もない）
End Sub
■４
書いておいてですが、本当に↓は正しいですか？
wbMoto.Worksheets("全得意先").Range("AC1").End(xlDown).Copy
↑だとオートフィルタで抽出する必要がないような気がしますが・・・・
（逆順検索して最初にヒットしたセルの行のAC列をコピペすればよい）
（もこな２） 2021/04/06(火) 07:12
もこな様 ■１ 後述しますがlr1,lrは統合しました。
■２
＞"1420" "1769" "1829"...等法則性のない数字になります。
それはどこかに書いてある（リストアップされている）のですか？
wbSaki（データの転記先）のA2～A10まで記載されています。
そのためwbSaki A列にある数字をwbMoto（元データ）から検索し、AC列をコピー
wbSaki E列にペーストすることが目的になります。
最初に上手く伝えられず申し訳ありませんでした。
■３■４
言われてみればフィルターにこだわらず.Findでも問題なく処理ができました。
そこで下記のような繰り返し処理をしたいのですが、エラーがでてしまいうまくいきません。
Dim wbMoto As Workbook, wbSaki As Workbook
Dim lr As Long
Dim OpenFileName As String
Dim Rng As Range
Dim k As Range
Dim i As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
SetFile = OpenFileName
Set wbSaki = ThisWorkbook
Set wbMoto = Workbooks.Open(SetFile)
'----▼▼▼-----ここから繰り返す----▼▼▼-----
Set k = wbSaki.Sheets("売上").Range("A" & i)
i = 2
Do Until i <= 10
wbMoto.Range("D:D").Find("k", SearchOrder:=xlByRows, SearchDirection:=xlNext).Offset(, 25).Copy’▲ここで438エラーになります。
wbSaki.Worksheets("売上").Range("E" & lr + 1).PasteSpecial Paste:=xlPasteValues
i = i +1
Loop
'----▲▲▲-----ここまで繰り返す----▲▲▲----- wbMoto.Close False
Application.DisplayAlerts = False End Sub
そもそも.Find(what)に変数はいれられないのでしょうか？
？
（SS） 2021/04/07(水) 00:20
■６
よくわからないので確認です。
(1)↓はなんで必要なんですか？ SetFile = OpenFileName
(2)↓だと「k」という文字列を検索してますが、おかしくないですか？
wbMoto.Range("D:D").Find("k", SearchOrder:=xlByRows, SearchDirection:=xlNext)
(3)↓だと「SearchDirection:=xlNext」なので、２番目のセルから正順で検索しますけどそれでよいのですか？
wbMoto.Range("D:D").Find("k", SearchOrder:=xlByRows, SearchDirection:=xlNext)
(4)↓だと「LookIn」「LookAt」が省略されているので、前回値を承継しますけどそれでよいのですか？
wbMoto.Range("D:D").Find("k", SearchOrder:=xlByRows, SearchDirection:=xlNext)
(5)↓だと今回のようにFindメソッドの結果がNothingだった（＝見つからなかった）場合エラーになりますよ。
Rangeオブジェクト.Find(～～).Copy
■７
整理しなおすと（というか作り直すと）、こんな感じなんじゃないですか？
Sub さんぷる1()
Dim ブックパス As String
Dim srcSH As Worksheet
Dim 発見セル As Range
Dim i As Long
Stop 'ブレークポイントの代わり
'▼処理するのか判定
If MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
If ブックパス <> "False" Then
ブックパス = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
Else
MsgBox "キャンセルされました"
Exit Sub
End If
Else
MsgBox "処理を中断します"
Exit Sub
End If
'▼変数のセット等
Set srcSH = Workbooks.Open(ブックパス).Worksheets("全得意先")
'▼繰り返し処理
With ThisWorkbook.Sheets("売上")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 1
Set 発見セル = srcSH.Range("D:D").Find(What:=.Cells(i, "A"), LookIn:=xlValues, SearchDirection:=xlNext, LookAt:=xlPart, SearchDirection:=xlPrevious)
If 発見セル Is Nothing Then
.Cells(i, "E").Value = "発見できず"
Else
.Cells(i, "E").Value = srcSH.Cells(発見セル.Row, "AC").Value
End If
Next i
End With
'▼開いたブックを閉じる
srcSH.Paste.Close False
End Sub
■８
逆順検索でなくてよいなら、Findメソッドじゃなくてもいいですね。
Sub さんぷる2()
Dim ブックパス As String
Dim srcSH As Worksheet
Dim 発見行 As Variant '←エラー値を受け取れるようにVariant型にする
Dim i As Long
Stop 'ブレークポイントの代わり
'▼処理するのか判定
If MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
If ブックパス <> "False" Then
ブックパス = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
Else
MsgBox "キャンセルされました"
Exit Sub
End If
Else
MsgBox "処理を中断します"
Exit Sub
End If
'▼変数のセット等
Set srcSH = Workbooks.Open(ブックパス).Worksheets("全得意先")
'▼繰り返し処理
With ThisWorkbook.Sheets("売上")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 1
発見行 = Application.Match(.Cells(i, "A"), srcSH.Range("D:D"), 0)
If IsError(発見行) Then
.Cells(i, "E").Value = "発見できず"
Else
.Cells(i, "E").Value = srcSH.Cells(発見行, "AC").Value
End If
Next i
End With
'▼開いたブックを閉じる
srcSH.Paste.Close False
End Sub
（もこな２） 2021/04/07(水) 04:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.