Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Excel 2016)
フォームを使ってfindメソッドによるデータの抽出ができず困っています。
投稿日時: 17/06/18 21:42:46
投稿者: tom.n

お世話になります。
VBA駆け出しの者です。
フォームを使って日付のデータを指定し、findメソッドで別ファイルのexcelを検索して、結果をフォームを起動したexcelファイルにコピーしようとしているのですが、うまくいきません。皆様ご助力お願いいたします。
元になっている検索される側のファイルは
 
日付  タイトル  内容   提出先
2015/7/7 "xxxxxx" "12345" "市役所"
 
のような構成です。
 
以下が、フォームにテキスト(txt_dateという名前です)を入力してコマンドボタン(btn_dateという名前です)を押した時に動くSubです。
 
Private Sub btn_date_Click()
 
    '検索される側のブック、シート、セルの変数です'
   Dim wbOrg As Workbook
    Dim wsOrg As Worksheet
    Dim rgOrg As Range
 
  '検索結果をコピーして載せる側のシートと、セル範囲の変数です、こちらのファイルを開いてマクロを実行しています'
    Dim wsDst As Worksheet
    Dim cDst As Range
 
    'Findを実行した戻り値を保存している変数です'
    Dim myRange As Range
 
    'FindNextを使うために最初にFindした時のmyRangeをキープして後で、アドレスを使い、FindNextのループを抜けるための変数です'
    Dim rngKeep As Range
     
   Set wbOrg = Workbooks.Open(ThisWorkbook.Path & "\DB.xlsx")
    Set wsOrg = wbOrg.Worksheets(1)
    Set rgOrg = wsOrg.Range(wsOrg.Range("a1"), wsOrg.Cells(Rows.Count, 1).End(xlUp))
    Set wsDst = ThisWorkbook.Worksheets(1)
    Set cDst = wsDst.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
     
    Set myRange = rgOrg.Find(What:=Me.txt_date.Text, LookIn:=xlValues, Lookat:=xlWhole)
        
    If myRange Is Nothing Then
        MsgBox "該当の月日はありません"
        Exit Sub
    Else
        Set rngKeep = myRange
        myRange.Resize(1, 4).Copy Destination:=cDst
    End If
    Do
        Set myRange = Cells.FindNext(myRange)
        If myRange.Address = rngKeep.Address Then
            Exit Do
        Else
            myRange.Resize(1, 4).Copy Destination:=cDst
        End If
    Loop
End Sub
 
検索をかけられる側のファイルの一番上のレコード(findされたmyRangeから4列目までresizeしたデータ)はコピーされるのですが、2つめ、3つめがコピーされません。ですがエラーはでないのです。FindNextメソッドが動いてないのかとも思ったりしてるのですが、分からないです。
どうかよろしくお願いします

回答
投稿日時: 17/06/19 00:06:44
投稿者: 半平太

取りあえず、下の3行目を追加してみてください。
※cDstを一つ下に異動しないと、同じところを上書きしてしまうことになります。
 

>            Exit Do
>        Else
             Set cDst = cDst.Offset(1, 0) 
>           myRange.Resize(1, 4).Copy Destination:=cDst
>        End If

投稿日時: 17/06/19 05:58:04
投稿者: tom.n

お早い返信をありがとうございます!
 
指示いただいた通り、ループして出力するときにcDstにOffsetをしてあげると、うまく動きました。
結果が上書きされていたんですね。
 
解決しました。
ありがとうございました!