Excel VBA 質問スレッド №2042 (解決済)
一致したら転記する連続
投稿者 : そーりー 投稿日時 : 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
すいませんが教えてください。
シートAの名前とシートBの名前が一致し、シートAの曜日とシートBの曜日が一致すれば、シートAの曜日ごとの内容をシートBの月間表に転記ができるようにしたく。
1人が終了すれば、次の人も同様の処理をする。シートAには同じ行間隔で名前が続き、B列の名前がなくなるまで同様の処理を連続して行いたい。
名前の一致(どちらかに名前がない場合)ができなかった場合は、すべての処理後にその名前を表示したい。
以上のようなことしたく、自身でコード作成してみましたが動作せず、やればやるほどわからなくなってしまいました。
そもそもの処理の考え方がよくないのか。
すいませんが、ご教授いただけると幸いです。
よろしくお願いいたします。
シートA:https://ibb.co/dkc8sg9
シートB:https://ibb.co/nRfRgpM
スポンサーリンク
[返信 1] Re : 一致したら転記する連続
投稿者 : そーりー 投稿日時 : 2024/11/15(Fri) 23:48:52
すいません追記です。
シートBの月間表は、一人分は35行目で終了し、二人目は37行目からはじまり67行目で終了します。
三人目は69行目からはじまり99行目で終了します。以後この行間隔です。
すいません、どうぞよろしくお願いいたします。
すいません追記です。
シートBの月間表は、一人分は35行目で終了し、二人目は37行目からはじまり67行目で終了します。
三人目は69行目からはじまり99行目で終了します。以後この行間隔です。
すいません、どうぞよろしくお願いいたします。
[返信 2] Re : 一致したら転記する連続
投稿者 : てらてら 投稿日時 : 2024/11/16(Sat) 04:59:35
こんにちは。
ツッコミ所は多々あると思いますが、基本的には以下のようになると思います。
考え方としては、シートAの名前、曜日を捕まえて、シートBと突き合わせて、シートAの曜日の行と相対的な列から転記します。
For文が深くなるとわかりずらくなると思いますが、一階層ずつ確認しながら進めていけば混乱しません。
こんにちは。
ツッコミ所は多々あると思いますが、基本的には以下のようになると思います。
考え方としては、シート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
[返信 3] Re : 一致したら転記する連続
投稿者 : そーりー 投稿日時 : 2024/11/16(Sat) 21:21:46
てらてら様。
ありがとうございます。
おかげさまでやりたいことができました。
追加質問申し訳ありませんが、セルの斜線を転記させることは通常難しいでしょうか?
てらてら様。
ありがとうございます。
おかげさまでやりたいことができました。
追加質問申し訳ありませんが、セルの斜線を転記させることは通常難しいでしょうか?
[返信 4] Re : 一致したら転記する連続
投稿者 : てらてら 投稿日時 : 2024/11/17(Sun) 13:41:56
簡単ですよ。
以下のコードは選択したセルに斜線がある場合、それを消すコードです。
参考にしてみてください。
SelectionをRangeやCellsに変えればOKです。
こういうのは、マクロの記録を使えば、必要な事が見えてきます。
簡単ですよ。
以下のコードは選択したセルに斜線がある場合、それを消すコードです。
参考にしてみてください。
SelectionをRangeやCellsに変えればOKです。
こういうのは、マクロの記録を使えば、必要な事が見えてきます。
Sub testCode() With Selection.Borders(xlDiagonalUp) If .LineStyle = xlContinuous Then .LineStyle = xlNone End If End With End Sub
[返信 5] Re : 一致したら転記する連続
投稿者 : そーりー 投稿日時 : 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
[返信 6] Re : 一致したら転記する連続
投稿者 : てらてら 投稿日時 : 2024/11/17(Sun) 21:35:07
Copy と PasteSpecial を使うならレンジを広範囲に取った方が速度は稼げるでしょう。
速度を早くしたければ、繰り返すを減らすのが原則です。
後は、定番の Application.ScreenUpdating = False ですね。
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
[返信 7] Re : 一致したら転記する連続
投稿者 : そーりー 投稿日時 : 2024/11/17(Sun) 22:35:09
何度もありがとうございます。
大変感謝です。
何度もありがとうございます。
大変感謝です。
当掲示板について
- Excel VBA に関する掲示板です。Excel VBA に関する質問や疑問、それに対する解決方法など気軽に投稿してください。
- 記事内ではHTMLのタグは使用できません。
- 記事は一度投稿すると修正できません。内容を訂正したい場合は返信で対応してください。
- Sub〜End Sub、Function〜End Function は自動的にプログラムコードとみなし、枠で囲って見やすくします。
- Excel VBA とは関係ないことや、他人が不快に思うようなことなど、管理人が適当でないと判断した記事は削除する場合があります。
スポンサーリンク
返信入力フォーム
( 処理日時 : 2024-12-07 23:53:17 )