一致したら転記する連続

投稿者 : そーりー     投稿日時 : 2024/11/15(Fri) 23:43:04     OS : Windows 10     EXCEL : Excel 2019

---

すいませんが教えてください。
シートAの名前とシートBの名前が一致し、シートAの曜日とシートBの曜日が一致すれば、シートAの曜日ごとの内容をシートBの月間表に転記ができるようにしたく。
1人が終了すれば、次の人も同様の処理をする。シートAには同じ行間隔で名前が続き、B列の名前がなくなるまで同様の処理を連続して行いたい。
名前の一致（どちらかに名前がない場合）ができなかった場合は、すべての処理後にその名前を表示したい。
以上のようなことしたく、自身でコード作成してみましたが動作せず、やればやるほどわからなくなってしまいました。
そもそもの処理の考え方がよくないのか。
すいませんが、ご教授いただけると幸いです。
よろしくお願いいたします。

シートA：https://ibb.co/dkc8sg9
シートB：https://ibb.co/nRfRgpM

投稿者 : そーりー     投稿日時 : 2024/11/15(Fri) 23:48:52

---

すいません追記です。
シートBの月間表は、一人分は35行目で終了し、二人目は37行目からはじまり67行目で終了します。
三人目は69行目からはじまり99行目で終了します。以後この行間隔です。
すいません、どうぞよろしくお願いいたします。

投稿者 : てらてら     投稿日時 : 2024/11/16(Sat) 04:59:35

---

こんにちは。

ツッコミ所は多々あると思いますが、基本的には以下のようになると思います。

考え方としては、シートAの名前、曜日を捕まえて、シートBと突き合わせて、シートAの曜日の行と相対的な列から転記します。
For文が深くなるとわかりずらくなると思いますが、一階層ずつ確認しながら進めていけば混乱しません。

Sub macro()
    Dim shA As Worksheet
    Dim shB As Worksheet
    Set shA = Worksheets("シートA")
    Set shB = Worksheets("シートB")
    
    Dim bName As String
    Dim yobi As String
    Dim i As Long, j As Long, k As Long
    Dim lastRowA As Long
    lastRowA = shA.Cells(Rows.Count, "B").End(xlUp).row
    Dim lastRowB As Long
    lastRowB = shB.Cells(Rows.Count, "A").End(xlUp).row
    
    
    For i = 2 To lastRowA Step 7
        'Debug.Print shA.Cells(i, "B")
        bName = shA.Cells(i, "B")
        For j = i + 1 To i + 5
            'Debug.Print shA.Cells(j, "C")
            yobi = shA.Cells(j, "C").Text
            'Debug.Print yobi
            
            For k = 5 To lastRowB
                'Debug.Print shB.Cells(k, "B").Text
                If shB.Cells(k, "B").Text = yobi And shB.Cells(k, "C") = bName Then
                    shB.Cells(k, "D") = shA.Cells(j, "D")
                    shB.Cells(k, "D").NumberFormatLocal = shA.Cells(j, "D").NumberFormatLocal
                    shB.Cells(k, "E") = shA.Cells(j, "E")
                    shB.Cells(k, "E").NumberFormatLocal = shA.Cells(j, "E").NumberFormatLocal
                    shB.Cells(k, "F") = shA.Cells(j, "F")
                    shB.Cells(k, "G") = shA.Cells(j, "G")
                    shB.Cells(k, "H") = shA.Cells(j, "H")
                    shB.Cells(k, "I") = shA.Cells(j, "I")
                End If
            Next k
        Next j
    Next i
        
End Sub

投稿者 : そーりー     投稿日時 : 2024/11/16(Sat) 21:21:46

---

てらてら様。
ありがとうございます。
おかげさまでやりたいことができました。
追加質問申し訳ありませんが、セルの斜線を転記させることは通常難しいでしょうか？

投稿者 : てらてら     投稿日時 : 2024/11/17(Sun) 13:41:56

---

簡単ですよ。
以下のコードは選択したセルに斜線がある場合、それを消すコードです。
参考にしてみてください。
SelectionをRangeやCellsに変えればOKです。

こういうのは、マクロの記録を使えば、必要な事が見えてきます。

Sub testCode()
    With Selection.Borders(xlDiagonalUp)
        If .LineStyle = xlContinuous Then
            .LineStyle = xlNone
        End If
    End With
End Sub

投稿者 : そーりー     投稿日時 : 2024/11/17(Sun) 16:58:19

---

ありがとうございます。
いただいたコードを参考に自分なりに作成してみました。
斜線を転記したく下記コードを作成しましたが、時間が非常にかかる点と、クリップボードエラーが発生しました。
改良できる点ありましたらお暇なときにご教授いただけると幸いです。
勝手ばかり言い申し訳ございません。

Sub macro()
    Dim shA As Worksheet
    Dim shB As Worksheet
    Set shA = Worksheets("シートA")
    Set shB = Worksheets("シートB")
    
    Dim bName As String
    Dim yobi As String
    Dim i As Long, j As Long, k As Long
    Dim lastRowA As Long
    lastRowA = shA.Cells(Rows.Count, "B").End(xlUp).row
    Dim lastRowB As Long
    lastRowB = shB.Cells(Rows.Count, "A").End(xlUp).row
    
    
    For i = 2 To lastRowA Step 7
        'Debug.Print shA.Cells(i, "B")
        bName = shA.Cells(i, "B")
        For j = i + 1 To i + 5
            'Debug.Print shA.Cells(j, "C")
            yobi = shA.Cells(j, "C").Text
            'Debug.Print yobi
            
            For k = 5 To lastRowB
                'Debug.Print shB.Cells(k, "B").Text
                If shB.Cells(k, "B").Text = yobi And shB.Cells(k, "C") = bName Then
                   shA.Cells(j, "D").Copy
                   shB.Cells(k, "D").PasteSpecial Paste:=xlPasteAll
 
                   shA.Cells(j, "E").Copy
		   shB.Cells(k, "E").PasteSpecial Paste:=xlPasteAll
 
                   shA.Cells(j, "F").Copy
                   shB.Cells(k, "F").PasteSpecial Paste:=xlPasteAll
 
                   shA.Cells(j, "G").Copy
                   shB.Cells(k, "G").PasteSpecial Paste:=xlPasteAll

　　　　　　　　　 shA.Cells(j, "H").Copy
                   shB.Cells(k, "H").PasteSpecial Paste:=xlPasteAll

                   shA.Cells(j, "I").Copy
                   shB.Cells(k, "I").PasteSpecial Paste:=xlPasteAll

                End If
            Next k
        Next j
    Next i
        
End Sub

投稿者 : てらてら     投稿日時 : 2024/11/17(Sun) 21:35:07

---

Copy と PasteSpecial を使うならレンジを広範囲に取った方が速度は稼げるでしょう。
速度を早くしたければ、繰り返すを減らすのが原則です。

後は、定番の Application.ScreenUpdating = False ですね。

Sub macro()
    Dim shA As Worksheet
    Dim shB As Worksheet
    Set shA = Worksheets("シートA")
    Set shB = Worksheets("シートB")
    
    Dim bName As String
    Dim yobi As String
    Dim i As Long, j As Long, k As Long
    Dim lastRowA As Long
    lastRowA = shA.Cells(Rows.Count, "B").End(xlUp).row
    Dim lastRowB As Long
    lastRowB = shB.Cells(Rows.Count, "A").End(xlUp).row
    
    Application.ScreenUpdating = False

    For i = 2 To lastRowA Step 7
        bName = shA.Cells(i, "B")
            
        For k = 5 To lastRowB
            If shB.Cells(k, "B").Text = "月" And shB.Cells(k, "C") = bName Then
                
               shA.Cells(i + 1, "D").Resize(5, 6).Copy
               shB.Cells(k, "D").PasteSpecial Paste:=xlPasteAll
                
            End If
        Next k

    Next i
        
    Application.ScreenUpdating = True
    MsgBox "終了"
End Sub

投稿者 : そーりー     投稿日時 : 2024/11/17(Sun) 22:35:09

---

何度もありがとうございます。
大変感謝です。