Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


33713 / 76734 ←次へ | 前へ→

【48237】Re:条件一致行を探し、日付・担当を転記
回答  りん E-MAIL  - 07/4/9(月) 19:30 -

引用なし
パスワード
   かおピ さん、こんばんわ。

>Sheet1 の日々の日計表の2名の条件と一致するものを
>Sheet2 の中から探し、
>A:月 B:日 C:名前   D:金額  E:入金日 F:担当者
>4  1   鈴木一郎  1050
>4  1   浅田真央  980
>4  2   田口 壮   2000   4/9    片山
>4  4   鈴木一郎  550    4/9    松田
> このように、入金日と担当者を転記したいのです。
担当者名が完全一致検索できて、重複がないとして。

Sub test()
  Dim ws1 As Worksheet, ws2 As Worksheet, r1 As Range
  Dim s1 As String, s2 As String, RR As Long, Rmax As Long
 
  'シートセット
  With Application.ActiveWorkbook
   Set ws1 = .Worksheets("Sheet1") '転記元
   Set ws2 = .Worksheets("Sheet2") '転記先
  End With
  '検索をかけて、ヒットしたら転記(重複はないとする)
  Rmax = ws2.Range("C65536").End(xlUp).Row
  For RR = 2 To Rmax
   If ws2.Cells(RR, 3).Value <> "" Then
     With ws1.Columns(2)
      Set r1 = .Find(what:=ws2.Cells(RR, 3).Value, After:=.Cells(1))
      If Not r1 Is Nothing Then
      '
        Do
         s1 = r1.Address
         If r1.Offset(0, 1).Value = ws2.Cells(RR, 1).Value And _
           r1.Offset(0, 2).Value = ws2.Cells(RR, 2).Value And _
           r1.Offset(0, 3).Value = ws2.Cells(RR, 4).Value Then
           '
           'Sheet1のCDEとSheet2のABDが一致したら
           ws2.Cells(RR, 5).Value = r1.Offset(0, -1).Value
           ws2.Cells(RR, 6).Value = r1.Offset(0, 4).Value
           Exit Do 'Loop終了
         End If
         Set r1 = .FindNext(r1)
        Loop While Not r1 Is Nothing And r1.Address <> s1
      End If
     End With
   End If
  Next
  '
  Set r1 = Nothing
  Set ws1 = Nothing: Set ws2 = Nothing
 
End Sub

こんな感じです。
5 hits

【48234】条件一致行を探し、日付・担当を転記 かおピ 07/4/9(月) 17:30 質問
【48237】Re:条件一致行を探し、日付・担当を転記 りん 07/4/9(月) 19:30 回答
【48241】Re:条件一致行を探し、日付・担当を転記 かおピ 07/4/9(月) 21:16 質問
【48243】Re:条件一致行を探し、日付・担当を転記 りん 07/4/9(月) 21:53 回答
【48247】Re:条件一致行を探し、日付・担当を転記 かおピ 07/4/9(月) 22:57 お礼
【48292】Re:条件一致行を探し、日付・担当を転記 かおピ 07/4/11(水) 23:18 質問

33713 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free