VBAで別シートの文字検索をして元のシートに値を返したい(その3)

実現したいこと

①メッセージボックスに入力した値をシート2で検索する
※入力値が空白の場合は終了する
②シート2の文字検索結果の値をシート1に返す
③①の処理が7回完了したら下に5セル移動する
④再度①の処理を繰り返す

発生している問題・分からないこと

①の処理はできますが、③～④にかけての処理がうまくいきません。

該当のソースコード

    For i = 1 To 7 Step 7
    
        myprompt = "項目を入力してください"
        mytitle = "作成"
        x = Application.InputBox(myprompt, mytitle)
        
        If x = "" Then Exit For

            Sheets("シート2").Activate
            Set foundCell = Cells.Find(What:=x, LookIn:=xlFormulas, LookAt:=xlPart)
    
            foundCell.Activate
    
            ex1 = ActiveCell.Offset(0, -2).Value
            ex2 = ActiveCell.Offset(0, -1).Value
            ex3 = ActiveCell.Offset(0, 1).Value
            koumoku1 = ActiveCell.Offset(0, 2).Value
            koumoku2 = ActiveCell.Offset(0, 3).Value
            koumoku3 = ActiveCell.Offset(0, 4).Value
            koumoku4 = ActiveCell.Offset(0, 5).Value
            koumoku5 = ActiveCell.Offset(0, 6).Value

            If Not foundCell Is Nothing Then
            
                If i = 1 Then
            
                    Sheets("シート1").Activate
                
                    Range("C7").Activate
                    Range("C7").Value = ex1
        
                    ActiveCell.Offset(0, 2).Activate
                    ActiveCell.Value = ex2
                
                    ActiveCell.Offset(1, 0).Activate
                    ActiveCell.Value = foundCell
        
                    ActiveCell.Offset(1, 0).Activate
                    ActiveCell.Value =  ex3

                    ActiveCell.Offset(-2, 0).Activate
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku1
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku2
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku3
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku4
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku5
                    
                    ActiveCell.Offset(2, 0).Activate
                    ActiveCell.Offset(0, -7).Activate
                    
                ElseIf i = 7 Then
                
                    Sheets("シート1").Activate
                
                    ActiveCell.Offset(5, 0).Activate
                
                Else
                
                    Sheets("シート1").Activate
                
                    ActiveCell.Value = ex1
        
                    ActiveCell.Offset(0, 2).Activate
                    ActiveCell.Value = ex2
                
                    ActiveCell.Offset(1, 0).Activate
                    ActiveCell.Value = foundCell
        
                    ActiveCell.Offset(1, 0).Activate
                    ActiveCell.Value = ex3

                    ActiveCell.Offset(-2, 0).Activate
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku1
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku2
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku3
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku4
        
                    ActiveCell.Offset(0, 1).Activate
                    ActiveCell.Value = koumoku5
                    
                    ActiveCell.Offset(2, 0).Activate
                    ActiveCell.Offset(0, -7).Activate
                    

                    
                End If
                

        
            Else
                MsgBox "見つかりませんでした。", vbExclamation
            End If

        Next i

試したこと・調べたこと

teratailやGoogle等で検索した
ソースコードを自分なりに変更した
知人に聞いた
その他

上記の詳細・結果

7回目までは実施可能だが、8回目以降がうまくいかない

補足

特になし

行動規範の内容に同意します

回答1件

ベストアンサー

まぁ、ちょっと変数の宣言とかインデントの使い方とかActivateの多用とか勉強する部分は多そうですが､今のコードで行うとしたら以下の通りでしょう。

VBA
1Sub Test()
2    Dim x
3    Dim i
4    Dim myprompt
5    Dim mytitle
6    Dim koumoku1
7    Dim koumoku2
8    Dim koumoku3
9    Dim koumoku4
10    Dim koumoku5
11    Dim ex1
12    Dim ex2
13    Dim ex3
14    Dim foundCell
15    
16    For i = 1 To 7
17    
18        myprompt = "項目を入力してください"
19        mytitle = "作成"
20        x = Application.InputBox(myprompt, mytitle)
21        
22        If x = "" Then Exit For
23
24        Sheets("シート2").Activate
25        Set foundCell = Cells.Find(What:=x, LookIn:=xlFormulas, LookAt:=xlPart)
26
27        foundCell.Activate
28
29        ex1 = ActiveCell.Offset(0, -2).Value
30        ex2 = ActiveCell.Offset(0, -1).Value
31        ex3 = ActiveCell.Offset(0, 1).Value
32        koumoku1 = ActiveCell.Offset(0, 2).Value
33        koumoku2 = ActiveCell.Offset(0, 3).Value
34        koumoku3 = ActiveCell.Offset(0, 4).Value
35        koumoku4 = ActiveCell.Offset(0, 5).Value
36        koumoku5 = ActiveCell.Offset(0, 6).Value
37
38        If Not foundCell Is Nothing Then
39        
40            If i = 1 Then
41        
42                Sheets("シート1").Activate
43            
44                Range("C7").Activate
45                Range("C7").Value = ex1
46    
47                ActiveCell.Offset(0, 2).Activate
48                ActiveCell.Value = ex2
49            
50                ActiveCell.Offset(1, 0).Activate
51                ActiveCell.Value = foundCell
52    
53                ActiveCell.Offset(1, 0).Activate
54                ActiveCell.Value = ex3
55
56                ActiveCell.Offset(-2, 0).Activate
57                ActiveCell.Offset(0, 1).Activate
58                ActiveCell.Value = koumoku1
59    
60                ActiveCell.Offset(0, 1).Activate
61                ActiveCell.Value = koumoku2
62    
63                ActiveCell.Offset(0, 1).Activate
64                ActiveCell.Value = koumoku3
65    
66                ActiveCell.Offset(0, 1).Activate
67                ActiveCell.Value = koumoku4
68    
69                ActiveCell.Offset(0, 1).Activate
70                ActiveCell.Value = koumoku5
71                
72                ActiveCell.Offset(2, 0).Activate
73                ActiveCell.Offset(0, -7).Activate
74            
75            Else
76            
77                Sheets("シート1").Activate
78            
79                ActiveCell.Value = ex1
80    
81                ActiveCell.Offset(0, 2).Activate
82                ActiveCell.Value = ex2
83            
84                ActiveCell.Offset(1, 0).Activate
85                ActiveCell.Value = foundCell
86    
87                ActiveCell.Offset(1, 0).Activate
88                ActiveCell.Value = ex3
89
90                ActiveCell.Offset(-2, 0).Activate
91                ActiveCell.Offset(0, 1).Activate
92                ActiveCell.Value = koumoku1
93    
94                ActiveCell.Offset(0, 1).Activate
95                ActiveCell.Value = koumoku2
96    
97                ActiveCell.Offset(0, 1).Activate
98                ActiveCell.Value = koumoku3
99    
100                ActiveCell.Offset(0, 1).Activate
101                ActiveCell.Value = koumoku4
102    
103                ActiveCell.Offset(0, 1).Activate
104                ActiveCell.Value = koumoku5
105                
106                ActiveCell.Offset(2, 0).Activate
107                ActiveCell.Offset(0, -7).Activate
108                
109
110                
111            End If
112            
113            If (i - 1) Mod 7 = 0 Then
114            
115                Sheets("シート1").Activate
116            
117                ActiveCell.Offset(5, 0).Activate
118                
119            End If
120    
121        Else
122            MsgBox "見つかりませんでした。", vbExclamation
123        End If
124
125    Next i
126
127End Sub
128
129

for i = 1 to 7 step7
これを行うとiに1と7しか代入されません。
7回行うには｢step 7｣を消さなければなりません。
step 7は｢7個先まで飛ばす｣という事です。

それから

ElseIf i = 7 Then
この部分は7を指定してしまうとi=7を実行されるときに
｢5行先へ移動｣を実行されてしまうので｢転記を行ってから5行先に移動｣するなら
If外に
(i - 1) Mod 7 = 0
を､入れます。(1から7までしかループしないのでそもそもこの条件分岐が必要なのかどうか…)

もし､わからなければ一度chatGPTに聞いてみるといいかもしれません。

投稿2025/03/03 07:56

編集2025/03/03 08:04

Black_Velvet

総合スコア110

kansai5963

2025/03/03 08:16

回答ありがとうございます。試したところ問題が解決しました！ベストアンサーに選ばせていただきました。

kansai5963

2025/03/03 08:23

8回目のmsgboxが表示されないため再度トライしてみます。

Black_Velvet

2025/03/03 09:08

For Nextをもう少しだけ調べてみるといいと思います。繰り返しならDo Loopでもいけます。

kansai5963

2025/03/04 00:24

回答ありがとうございます。試してみましたが解決できませんでした。 Sub CopyDataRepeat() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim i As Integer Dim targetRow As Long Dim startRow As Long Dim copyCount As Integer ' シートを設定 Set wsSource = ThisWorkbook.Sheets("Sheet1") ' コピー元シート Set wsTarget = ThisWorkbook.Sheets("Sheet2") ' コピー先シート ' コピー開始行 startRow = 1 ' コピーする回数 copyCount = 7 ' 最初のコピー位置（ターゲットシートの最初の行） targetRow = 1 ' 7回コピーを繰り返す For i = 1 To 7 wsSource.Rows(startRow & ":" & startRow + copyCount - 1).Copy wsTarget.Rows(targetRow) targetRow = targetRow + copyCount ' コピーした分だけ次のターゲット行をずらす startRow = startRow + copyCount ' コピー元も次に進める Next i ' 5行下に移動して再度7回繰り返す targetRow = targetRow + 5 ' 5行下に移動 ' 7回コピーを繰り返す For i = 1 To 7 wsSource.Rows(startRow & ":" & startRow + copyCount - 1).Copy wsTarget.Rows(targetRow) targetRow = targetRow + copyCount ' コピーした分だけ次のターゲット行をずらす startRow = startRow + copyCount ' コピー元も次に進める Next i End Sub この場合どの辺りに原因がありそうでしょうか？

Black_Velvet

2025/03/04 07:37

このコードは1～7行目をコピーペースト､次に8～14行目を…を7回繰り返して転記先のシートだけ5行先へ移動してからまた50～56行目までコピーペースト､次に57～63行目を……を7回繰り返して"コード終了"となります。最終的にどうしたいのでしょうか。

kansai5963

2025/03/04 07:42

シート２記載のリストに対し検索を行い、該当番号があったものに対し左右のセル(複数)をシート1に転記します。ただし、シート1には7項目分までしか入力できず、8項目目は7項目目から5行下にある状態です。そのため、該当番号の検索が7回目まで終了した際に5行下に移動させて8項目目の入力(転記)を開始したいです。メッセージボックスに空白を入力すると抜けるように設定しています。

Black_Velvet

2025/03/04 08:17

ん？CopyDataRepeatの件ではなくスレ元の件ですね？ For Nextが1 to 7なので7回しか行いません。1 to 100なら100回行います。もし、その数が固定でないのならFor NextではなくDo Loopを使いましょう。ループの途中で抜けるにはExit Sub又はExit Doが使用できます。 If foundCell Is Nothing Then MsgBox "見つかりませんでした。", vbExclamation Exit Sub End If ループの途中でもこんな感じでコードを終了できます。

行動規範の内容に同意します