転記した先の行6行に表示されるが7行目に表示して整理したい

投稿者 : こうど     投稿日時 : 2026/04/10(Fri) 23:14:04     OS : Windows 10     EXCEL : Excel 2019

---

Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r As Long, c As Long
Dim fl As Variant
Dim i As Long, j As Long, k As Long
Application.ScreenUpdating = False
'フロアシートのデータクリア
For Each sh2 In Worksheets
With sh2
If InStr(.Name, "フロア") Then
.Range("B2:P21").ClearContents
End If
End With
Next sh2
'処理
For Each sh1 In Worksheets
With sh1
If InStr(.Name, "フロア") = 0 Then
For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(r, 1).Value <> "" Then
'時間帯
Select Case r
Case Is < 5
i = 2
Case Is < 11
i = 7
Case Is < 16
i = 12
Case Else
i = 17
End Select
'各曜日
For c = 3 To 11 Step 2
fl = InStr(.Cells(r, c).Value, "(")
If fl > 0 Then
fl = Mid(.Cells(r, c).Value, fl + 1, 1)
Set sh2 = Worksheets(fl & "階フロア表")
For j = Int(c / 2) * 3 - 1 To Int(c / 2) * 3 + 1
For k = i To i + 4
If sh2.Cells(k, j).Value = "" Then
sh2.Cells(k, j).Value = .Cells(r, c).Value
Exit For
End If
Next k
If k <= i + 4 Then Exit For
Next j
'全フロア表
Set sh2 = Worksheets("全フロア表")
For j = Int(c / 2) * 3 - 1 To Int(c / 2) * 3 + 1
For k = i To i + 4
If sh2.Cells(k, j).Value = "" Then
sh2.Cells(k, j).Value = .Cells(r, c).Value
Exit For
End If
Next k
If k <= i + 4 Then Exit For
Next j
End If
Next c
End If
Next r
End If
End With
Next sh1
Application.ScreenUpdating = True
End Sub

Excelの違うシートに整理して転記するコードを教えて頂きながら作成しましたが
転記先の4列7行で整理し転記させているのですが7行目に整理がなされず困っています。
以上どこを修正すればよろしいでしょうか？

投稿者 : てらてら     投稿日時 : 2026/04/11(Sat) 05:37:51

---

こんにちは。
データが無いのと、何がしたいのかイマイチよくわからないのですが、
以下のようにDebug.Print で動作を確認してやれば原因が見つかると思います。

sh2.Cells(k, j).Value = .Cells(r, c).Value
７行目に転記したいのであれば、kが7にならないといけないので、この辺を見直してはいかがでしょうか？

Sub test()
                    ’---省略--
                    
                    '各曜日
                    For c = 3 To 11 Step 2
                        fl = InStr(.Cells(r, c).Value, "(")
                        If fl > 0 Then
                            fl = Mid(.Cells(r, c).Value, fl + 1, 1)
                            Debug.Print "fl=" & fl
                            
                            Set sh2 = Worksheets(fl & "階フロア表")
                            For j = Int(c / 2) * 3 - 1 To Int(c / 2) * 3 + 1
                                For k = i To i + 4
                                    If sh2.Cells(k, j).Value = "" Then
                                  
                                        Debug.Print "k=" & k & " j=" & j & ":  r=" & r & "  c=" & c & "  value=" & .Cells(r, c).Value
                                        sh2.Cells(k, j).Value = .Cells(r, c).Value
                                        
                                        Exit For
                                    End If
                                Next k
                                If k <= i + 4 Then Exit For
                            Next j
                            
                            ’---省略--

End Sub

投稿者 : ピロリ     投稿日時 : 2026/04/11(Sat) 10:20:06

---

ご提示のコードを見た感じでは、
＞ Select Case r
＞ Case Is < 5
＞ i = 2
　　：
＞ End Select
転記元の行(r)によって、転記先の先頭行(i)を切り換えて、
＞ For j = Int(c / 2) * 3 - 1 To Int(c / 2) * 3 + 1
＞ For k = i To i + 4
＞ If sh2.Cells(k, j).Value = "" Then
＞ sh2.Cells(k, j).Value = .Cells(r, c).Value
転記先の3列(j)×5行(k)内の空セルへ データを転記するって処理のようですけど、
＞ 転記先の4列7行で整理し転記させているのですが7行目に整理がなされず困っています。
｢4列7行｣とか ｢7行目｣とか 何を仰っているのか読み取れませんでした。

てらてらさんの Debug.Print（転記できたデータの出力）に加えて、
Next j　の後で、↓転記できなかったデータを調べてみても良いかもしれません。
If j > Int(c / 2) * 3 + 1 Then
　　Debug.Print "r=" & r & " c=" & c & " value=" & .Cells(r, c).Value & "：空セルが無く転記不可"
End If

転記先の 3列×5行（15セル）っていうのが 小さいだけのような気がしますけど･･･
例えば、r が 5～10行目のときに、c が 5回ループするなら、30セルの転記エリアが必要とか？

投稿者 : ピロリ     投稿日時 : 2026/04/11(Sat) 12:04:38

---

■[返信 2] の記事
＞ 例えば、r が 5～10行目のときに、c が 5回ループするなら、30セルの転記エリアが必要とか？
c は曜日？のループで、別の列へ転記することになるので、↑の記載は私の勘違いでしたね。　失礼しました。