| |
▼JIRORO さん：
出張、おつかれさまでした。
コードで気になるところは多々あるのですが、直接の間違いポイントは
s.Range(s.Cells(f, 1), s.Cells(f, 7)).Copy
f は このシートで最初に見つかったセルの行番号ですから、常に、この行の内容がコピペされます。
かといって、毎回、この f を変更すると、ループでの最終制御ができなくなります。
s.Range(s.Cells(c.Row, 1), s.Cells(c.Row, 7)).Copy
こうすれば、とりあえずはＯＫになるはずです。
ところで、Set c = s.Range("B:B").Find(what:=a)
Findメソッドで検索開始セルを指定しない場合、その領域の最初が検索開始セルになります。
一見、よさそうに見えますが、実は、検索開始セルの「次から」検索しなさいという機能なので
これでは、B1の次からという意味になってしまい、B1が最後に検索されます。
ですから、仮に、B1に検索値と同じものが入っていても、それはtestシートの下の方にコピペされることになります。
対応策としては、その領域の最後のセルを開始セルにします。
実際には開始セルの次からの検索ですから、つまりB1からということになります。
そのほかの構成は、基本、アップされたコードのままで、ちょっとお化粧直しをしたものが以下です。
（ f を行番号で使っておられますが、以下ではセルアドレス変数にしてあります）
Sub Sample()
Dim s As Worksheet
Dim sh2 As Worksheet
Dim myR As Range
Dim a As Variant
Dim c As Range
Dim f As Range
Dim las As Long
las = 1
Set sh2 = Sheets("test")
sh2.Columns("A:G").ClearContents
a = sh2.Range("H1").Value '仮です
For Each s In Worksheets
If Not s Is sh2 Then 'testシート以外を対象に
If MsgBox(s.Name & "を検索しますか", vbYesNo) = vbYes Then
Set myR = s.Range("B1", s.Range("B" & s.Rows.Count).End(xlUp))
Set c = myR(myR.Cells.Count)
Set c = myR.Find(what:=a, After:=c, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlWhole, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False)
If Not c Is Nothing Then
Set f = c
Do
sh2.Cells(las, 1).Resize(, 7).Value = s.Cells(c.Row, "A").Resize(, 7).Value
las = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 1
Set c = myR.FindNext(c)
Loop While c.Address <> f.Address
End If
End If
End If
Next
sh2.Select
Set sh2 = Nothing
Set c = Nothing
Set f = Nothing
MsgBox "貼り付けが終了しました"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
