検索してないものを最終行に記述する

質問

worksheetAのSheet1 Ａ列と worksheetＢのSheet1 Ａ列を比べてworksheetＢに含まれていないものをworksheetA A列Ｂ列より抽出してworksheetＢ A列最終行Ｂ列最終行にそれぞれ書き込むマクロを教えてください

当方作成してみたのですがどうも.nameで名前の定義をしたのですが他bookでは参照されずにインデックスエラーとなってしまいました。行数がお互い3000位あるので作業速度も重視したいのですがお願いいたします。

回答No.6

kmetu · ベストアンサー

すみません、他で使ってたのを流用したので、Loopが必要ないのにLoopを利用してました。
Exit doの説明をつけるときに気がつけよって話しなんですがすみません。

Loopなしのコードです。

Sub RWSample4()

Dim Nakattayannke As Boolean
Dim MyPickUpBook As Workbook
Dim MyS_W_Book As Workbook
Dim MyLastRow As Long, MyAddDataRow As Long, i As Long
Dim MyRange As Range

Set MyPickUpBook = Workbooks("BookA.xls")
Set MyS_W_Book = Workbooks("BookB.xls")

Application.ScreenUpdating = False

MyLastRow = MyPickUpBook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

With MyS_W_Book.Sheets("Sheet1")
For i = 1 To MyLastRow
Nakattayannke = True
Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Find(MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value, LookIn:=xlValues)
If Not MyRange Is Nothing Then
Nakattayannke = False
End If
If Nakattayannke Then
MyAddDataRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("A" & i)
.Range("B" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("B" & i)
End If
Next i
End With
Application.ScreenUpdating = True

End Sub

お礼

返答遅くなって申し訳ありません。
何度もありがとうございます。
感謝しております、A,B比べてないものすべてを最終行に書き出したいので最後まで検索して構わないようです、
本日TRYして見ますのでわからないことあればご指導していただいてもよろしいですか？

補足

完璧な内容でした、本当にありがとうございます。
重い通りのものをありがとうございました。
私が作ったものは初心者なので範囲指定に.nameを使った為別BOOKのものがインデックスエラーになってしまいました。
今後もっと勉強していきたいと思います。本当にありがとうございました。

回答No.5

kmetu

まことに何度も申し訳ないです。一部抜けてました。

Do
Nakattayannke = False
Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).FindNext(MyRange)
Loop While Not MyRange Is Nothing And MyRange.Address <> firstAddress

のところの

Nakattayannke = False

のところを以下のようにExit Doを追加してください。入れ忘れてました。これが無いと見つかっても最後の行まで検索を続けてしまいます。

Nakattayannke = False
Exit Do

回答No.4

kmetu

何度も申し訳ないです。

With～End Withが多重になっていて嫌な感じでしたら以下のようにしてください。ただし、FindとFindNextの2箇所にセル指定が入るのでちょっと記述が長くなります。

Sub RWSample3()

Dim Nakattayannke As Boolean
Dim MyPickUpBook As Workbook
Dim MyS_W_Book As Workbook
Dim MyLastRow As Long, MyAddDataRow As Long, i As Long
Dim MyRange As Range
Dim firstAddress As String

Set MyPickUpBook = Workbooks("BookA.xls")
Set MyS_W_Book = Workbooks("BookB.xls")

Application.ScreenUpdating = False

MyLastRow = MyPickUpBook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

With MyS_W_Book.Sheets("Sheet1")
For i = 1 To MyLastRow
Nakattayannke = True
Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Find(MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value, LookIn:=xlValues)
If Not MyRange Is Nothing Then
firstAddress = MyRange.Address
Do
Nakattayannke = False
Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).FindNext(MyRange)
Loop While Not MyRange Is Nothing And MyRange.Address <> firstAddress
End If
If Nakattayannke Then
MyAddDataRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("A" & i)
.Range("B" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("B" & i)
End If
Next i
End With
Application.ScreenUpdating = True

End Sub

回答No.3

kmetu

一部訂正です。重複してました

Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Find(MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value, LookIn:=xlValues)

の部分

Set MyRange = .Find(MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value, LookIn:=xlValues)

こちらに修正してください。

回答No.2

kmetu

No1です
こちらの方が早い感じです。

Sub RWSample2()

Dim Nakattayannke As Boolean
Dim MyPickUpBook As Workbook
Dim MyS_W_Book As Workbook
Dim MyLastRow As Long, MyAddDataRow As Long, i As Long
Dim MyRange As Range
Dim firstAddress As String

Set MyPickUpBook = Workbooks("BookA.xls")
Set MyS_W_Book = Workbooks("BookB.xls")

Application.ScreenUpdating = False

MyLastRow = MyPickUpBook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Debug.Print MyLastRow

With MyS_W_Book.Sheets("Sheet1")
For i = 1 To MyLastRow
Nakattayannke = True
With MyS_W_Book.Sheets("Sheet1").Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
Set MyRange = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Find(MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value, LookIn:=xlValues)
If Not MyRange Is Nothing Then
firstAddress = MyRange.Address
Do
Nakattayannke = False
Set MyRange = .FindNext(MyRange)
Loop While Not MyRange Is Nothing And MyRange.Address <> firstAddress
End If
End With
If Nakattayannke Then
MyAddDataRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("A" & i)
.Range("B" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("B" & i)
End If
Next i
End With
Application.ScreenUpdating = True

End Sub

回答No.1

kmetu

worksheetAのSheet1
worksheetＢのSheet1

それぞれ
workbookAのSheet1
workbookＢのSheet1

と読み替えました。

Sub RWSample()

Dim Nakattayannke As Boolean
Dim MyPickUpBook As Workbook
Dim MyS_W_Book As Workbook
Dim MyLastRow As Long, MyAddDataRow As Long, i As Long
Dim MyRange As Range

Set MyPickUpBook = Workbooks("BookA.xls")
Set MyS_W_Book = Workbooks("BookB.xls")

Application.ScreenUpdating = False

MyLastRow = MyPickUpBook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Debug.Print MyLastRow

With MyS_W_Book.Sheets("Sheet1")
For i = 1 To MyLastRow
Nakattayannke = True
For Each MyRange In .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
If MyPickUpBook.Sheets("Sheet1").Range("A" & i).Value = MyRange.Value Then
Nakattayannke = False
End If
Next
If Nakattayannke Then
MyAddDataRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("A" & i)
.Range("B" & MyAddDataRow).Value = MyPickUpBook.Sheets("Sheet1").Range("B" & i)
End If
Next i
End With
Application.ScreenUpdating = True

End Sub