【VBA】7回ごとに同じ処理を繰り返す
Q&A
解決したいこと
シート2にある項目を検索して左右の値をシート1に返す。
7回繰り返したら5行下に移動する。
8回目以降も同様に7回繰り返したら5行下に移動する。
メッセージボックスに空白が入力されたら処理を完了する。
7回目までの繰り返しはうまくいきましたが、8回目以降で失敗します。
発生している問題・エラー
withのブロック数が設定されていません。
または、問題・エラーが起きている画像をここにドラッグアンドドロップ
該当するソースコード
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Variant
Dim myprompt As String
Dim mytitle As String
Dim foundCell As Range
Dim ex1 As Variant
Dim ex2 As Variant
Dim ex3 As Variant
Dim koumoku1 As Variant
Dim koumoku2 As Variant
Dim koumoku3 As Variant
Dim koumoku4 As Variant
Dim koumoku5 As Variant
Dim i As Integer
Dim cnt As Integer
Dim searchResult As String
i = 1
cnt = i + 1
Do While True
'i = 1
cnt = i + 1
For i = 1 To cnt
myprompt = "項目を入力してください"
mytitle = "作成"
x = Application.InputBox(myprompt, mytitle)
If x = "" Then
MsgBox "空白が入力されました。ループを終了します。"
Exit Do ' Forループを抜ける
' ユーザーが「キャンセル」を押した場合（xがvbCancelの場合）
ElseIf x = False Then
MsgBox "処理がキャンセルされました。ループを終了します。"
Exit Do ' Forループを抜ける
ElseIf Len(Trim(x)) = 0 Then
MsgBox "該当はありませんでした。。ループを終了します。"
Exit Do ' Forループを抜ける
End If
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("フォーマット").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 Mod 7 = 0 Then
MsgBox i & "回目の処理です。"
Sheets("フォーマット").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(5, 0).Activate
ActiveCell.Offset(0, -7).Activate
'i = i + 1
Else
Sheets("フォーマット").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
Loop
MsgBox "処理が完了しました。", vbExclamation
End Sub
自分で試したこと
chatGPTに聞いたりしましたが明確な回答は出ませんでした。
0
