日付と名前が一致すれば転記したい

投稿者 : チーズケーキ     投稿日時 : 2024/07/20(Sat) 17:33:39     OS : 未指定     EXCEL : 未指定

---

Aシート　
A列　　B列　　C列
2/1 田中　　1
2/1 岡田 1
2/2 島田 8
2/3 田中　　1.5
2/4 田中　　2

Bシート　↓転記したい形
X列　　Y列　　Z列
2/1 田中　　1
2/2 田中
2/3 田中 1.5
2/4 田中　　2
2/5 田中　　

Aシートで記録したものを、Bシートに転記したく下記コードを作成しましたが、うまくいかずご教授いただけますと・・・
ネットで調べ作成しました。よろしくお願いします。

Sub macrotest

Dim ws01 As Worksheet, ws02 As Worksheet
    Dim i  As Long, j  As Long, lRow  As Long, mRow As Long
    Dim CheckCells As Range
    
    Set ws01 = Worksheets("Aシート")  
    Set ws02 = Worksheets("Bシート")  
    
    lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 
    mRow = ws02.Cells(Rows.Count, "Y").End(xlUp).Row
    
    For i = 6 To lRow Step 1
        For j = 9 To mRow Step 1
      
            If ws01.Cells(j, "A").Cells(j, "B") = ws02.Cells(i, "X").Cells(i, "Y") Then 
               ws01.Cells(j, "C").Copy  
               ws02.Cells(i, "Z") = xlPasteValues  
                Exit For  
            End If
        Next j
    Next i
    
    MsgBox "転記を完了しました"
               
End Sub

投稿者 : さんこう     投稿日時 : 2024/07/20(Sat) 19:08:40

---

＞ネットで調べ作成

参考になれば。

＜vba if 複数条件＞
https://www.google.com/search?q=vba+if+%E8%A4%87%E6%95%B0%E6%9D%A1%E4%BB%B6

＜vba 転記 値＞
https://www.google.com/search?q=vba+%E8%BB%A2%E8%A8%98+%E5%80%A4

投稿者 : tek     投稿日時 : 2024/07/20(Sat) 20:39:51

---

excelのバージョンは？
ちなみにXLOOKUP関数が使えるなら（Office Premium,365,2021）なら関数を使いスピルさせ値に変更すれば良いです。

Sub Macro1()
    Dim 検索値     As String
    Dim 検索範囲   As String
    Dim 戻り範囲    As String
    Dim r           As Range
    
    Set r = Worksheets("Aシート").Range("A1")
    Set r = Application.Range(r, r.End(xlDown))
    検索範囲 = r.Address(, , , True) & "&" & r.Offset(, 1).Address(, , , True)
    戻り範囲 = r.Offset(, 2).Address(, , , True)
    Set r = Worksheets("Bシート").Range("X1")
    Set r = Application.Range(r, r.End(xlDown))
    検索値 = r.Address & "&" & r.Offset(, 1).Address
    With r.Offset(, 2)
        .Cells(1).Formula2 = "=xlookup(" & 検索値 & "," & 検索範囲 & "," & 戻り範囲 & ","""",0)"
        .Value = .Value
    End With
End Sub

投稿者 : てらてら     投稿日時 : 2024/07/21(Sun) 06:28:29

---

こんにちは。

とりあえず、3つ大きな間違いがあります。

まず、カウンタ変数の i と j が逆です。
ws01.Cells には i、ws02.Cells には j を使います。

それと、以下の書き方はダメです。
If ws01.Cells(j, "A").Cells(j, "B") = ws02.Cells(i, "X").Cells(i, "Y") Then

A列とX列、B列とY列をそれぞれ比較して、AND で繋ぎます。
If ws01.Cells(i, "A") = ws02.Cells(j, "X") And ws01.Cells(i, "B") = ws02.Cells(j, "Y") Then

最後は、貼り付けの方法がダメです。
ws02.Cells(j, "Z") = xlPasteValues
ではなく、
ws02.Cells(j, "Z").PasteSpecial Paste:=xlPasteValues
とします。

もし、数値を転記したいだけならCopyメソッドを使わず以下のようにも書けます。

ws01.Cells(i, "C").Copy
ws02.Cells(j, "Z").PasteSpecial Paste:=xlPasteValues
　　↓
ws02.Cells(j, "Z") = ws01.Cells(i, "C")

投稿者 : チーズケーキ     投稿日時 : 2024/07/21(Sun) 13:24:11

---

tek様。
ありがとうございます。
スピルという機能をはじめて知りました。
今後勉強してまいりたいと思います。

投稿者 : チーズケーキ     投稿日時 : 2024/07/21(Sun) 13:27:11

---

てらてら様。
ありがとうございます。
ご教授いただいた点を修正していきたいと思います。
またご質問させていただいてもよろしいでしょうか？
お手数おかけします。

投稿者 : チーズケーキ     投稿日時 : 2024/07/24(Wed) 18:22:29

---

みなさんありがとうございます。
おかげさまでうまく動作してくれました。
すいませんが、２つ課題が出てきたので質問させてください。
１つが、名前の一致の際、苗字の名前の間のスペースが半角と全角のパターンがあり、ひとつひとつ修正しています。
２つめが、同じ人が同日に複数回記録がある場合があり、その場合は合算を転記したいなと。（下記のような例）
いったん別シートに転記し、合算し、それを本シートに転記になるのかなーとか考えています。
すいませんが、お知恵をお借りできないでしょうか？


（例）
Aシート　
A列　　B列　　C列
2/1 田中　　1
2/1 岡田 1
2/1 田中　1
2/2 島田 8
2/3 田中　　1.5
2/4 田中　　2

Bシート　↓転記したい形
X列　　Y列　　Z列
2/1 田中　　2←（1＋1）
2/2 田中
2/3 田中 1.5
2/4 田中　　2
2/5 田中　　

投稿者 : さんこう     投稿日時 : 2024/07/24(Wed) 19:22:02

---

＞１つが、名前の一致の際、苗字の名前の間のスペースが半角と全角のパターンがあり、ひとつひとつ修正しています。

比較するときに、スペースを削除して比較するといいでしょう。

＜vba スペース削除 -TRIM＞
https://www.google.com/search?q=vba+%E3%82%B9%E3%83%9A%E3%83%BC%E3%82%B9%E5%89%8A%E9%99%A4+-TRIM


＞２つめが、同じ人が同日に複数回記録がある場合があり、その場合は合算を転記したいなと

現状、どのような方法で転記しているのか提示するとよろしいかと思います。

投稿者 : チーズケーキ     投稿日時 : 2024/07/24(Wed) 19:48:02

---

ありがとうございます。
お知恵いただける方いらっしゃれば、よろしくお願いします。

投稿者 : tek     投稿日時 : 2024/07/25(Thu) 10:25:40

---

>いったん別シートに転記し、合算し
別シート（"Cシート"）で1行目に項目行を追加し、データを転記後半角スペースを全角スペースに変換
その表をピボットテーブル化、行：A列・B列、Σ値：C列（合計）、レイアウト：表形式・アイテムのラベルをすべて繰り返す、
総計：列と行の集計を行わない、小計：小計を表示しない

>それを本シートに転記になるのかな
ピボットテーブルのままで良いと思います。

一例です。
各プロパティ等はヘルプ（F1key）で確認ください。

Sub make_Pivot()
    Const Cシート = "Cシート"
    Dim sh As Worksheet
    
    If Not Evaluate("isref(" & Cシート & "!A1)") Then make_Sheet Cシート
    Set sh = Worksheets(Cシート)
    With sh
        .Range("A1").CurrentRegion.Offset(1).ClearContents
        Worksheets("Aシート").Range("A1").CurrentRegion.Resize(, 3).Copy .Range("A2")
        .Columns("B:B").Replace " ", "　", LookAt:=xlPart   '半角スペースを全角スペースに変換
        .Range("E1").PivotTable.SourceData = .Range("A1").CurrentRegion.Address(, , xlR1C1)
        .Range("E1").PivotTable.RefreshTable
    End With
End Sub

Private Sub make_Sheet(s As String)
    Dim 項目() As String
    Dim pvch As PivotCache
    Dim pvf As PivotField
    'シート作成する
    With Worksheets.Add(after:=Worksheets(Worksheets.Count))
        .Name = s
        項目 = Split("A列 B列 C列")
        .Range("A1:C1").Value = 項目
        .Range("A2:C2").Value = Array(1, 1, 1)  '仮データ
        'ピポットキャッシュを作成する
        Set pvch = ThisWorkbook.PivotCaches.Create(xlDatabase, .Range("A1").CurrentRegion.Address(, , xlR1C1))
        'ピポットテーブルを作成する
        With pvch.CreatePivotTable(.Range("E1"))
        'ピポットテーブルにフィールドを指定する
            .PivotFields(項目(0)).Orientation = xlRowField  '行：A列
            .PivotFields(項目(0)).NumberFormat = "m/d;@"
            .PivotFields(項目(1)).Orientation = xlRowField  '   B列
            .PivotFields(項目(2)).Orientation = xlDataField 'Σ値：C列（合計）
            .RowAxisLayout xlTabularRow                     'レイアウト：表形式
            .RepeatAllLabels xlRepeatLabels                 '           アイテムのラベルをすべて繰り返す
            .ColumnGrand = False                            '総計：列と行の集計を行わない
            .RowGrand = False
            For Each pvf In .PivotFields                    '小計：小計を表示しない
                pvf.Subtotals(1) = False
            Next
        End With
    End With
End Sub

投稿者 : てらてら     投稿日時 : 2024/07/25(Thu) 19:08:02

---

>１つが、名前の一致の際、苗字の名前の間のスペースが半角と全角のパターンがあり、ひとつひとつ修正しています。

やり方は色々あると思いますが、取りあえず半角スペースに統一する方法を提示しておきます。


>２つめが、同じ人が同日に複数回記録がある場合があり、その場合は合算を転記したいなと。

これだと、Copy　PasteSpecial は使えないから、既にある値に加算すれば良いと思います。

Sub macrotest2()

    Dim ws01 As Worksheet, ws02 As Worksheet
    Dim i  As Long, j  As Long, lRow  As Long, mRow As Long
    Dim CheckCells As Range
    
    Set ws01 = Worksheets("Aシート")
    Set ws02 = Worksheets("Bシート")
    
    lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row
    mRow = ws02.Cells(Rows.Count, "Y").End(xlUp).Row
    
    ws02.Range("Z9:Z" & mRow).ClearContents
    
    For i = 6 To lRow
        ws01.Cells(i, "B") = Replace(ws01.Cells(i, "B"), "　", " ")
    Next i
    
    For i = 6 To lRow
        For j = 9 To mRow
            If ws01.Cells(i, "A") = ws02.Cells(j, "X") And ws01.Cells(i, "B") = ws02.Cells(j, "Y") Then
                ws02.Cells(j, "Z") = ws02.Cells(j, "Z") + ws01.Cells(i, "C")
                Exit For
            End If
        Next j
    Next i
    
    MsgBox "転記を完了しました"
               
End Sub

投稿者 : チーズケーキ     投稿日時 : 2024/07/26(Fri) 07:20:00

---

てらてら様。ありがとうございます。
>これだと、Copy　PasteSpecial は使えないから、既にある値に加算すれば良いと思います。

お手隙の際に、てらてら様が考えている加算の方法お聞きしてもいいでしょうか？

投稿者 : てらてら     投稿日時 : 2024/07/26(Fri) 18:22:38

---

22行目に書いてあります。