Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

20218 / 76732

←次へ　｜　前へ→


	【61936】Re:EXCEL VBA 繰返しと計算結果。

Hirofumi - 09/6/12(金) 23:56 -


	引用なし

	パスワード

>>ここで◆エラーになります。
>>　　　　　　　　　　　　　　　　　　　◆↓v4(I + 1, 1)<インデックスが有効な範囲にありません>
>>=========◆→　　If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
>　　　　　　　　　　delRowEnd = I '終わりの行を取得
>　　　　　　　　　　Exit For
>　　　　　　　　End If
>　　　　　　End If

このエラーの回避だけで言うなら簡単なのですが？

v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入

を

v4 = .Range("A1:A" & (LastRow4 + 1)).Value 'バリアントに代入

とすれば善いだけですが

もっと基本的に直すと（詳しくTestして居ませんが）以下の様にした方が善い様なきがします

Option Explicit

Private Sub CommandButton1_Click()

　　Dim Ws3 As Worksheet
　　Dim Ws4 As Worksheet
'　　Dim v3 As Variant
　　Dim v4 As Variant
'　　Dim LastRow3 As Long
　　Dim LastRow4 As Long
　　Dim NewRow As Long
　　Dim delRows As Long
'　　Dim delRowStart As Long
'　　Dim delRowEnd As Long
　　Dim i As Long
　　Dim strPrompt As String
　　
　　Set Ws3 = Sheet3
　　Set Ws4 = Sheet4

　　If Me.TextBox1.Text = "" Then
　　　　strPrompt = "*****日を入力してください。"
　　　　GoTo Wayout
　　End If

'　　With Ws3
　　　　'★LastRow3、v3を使って居ないので削除
'　　　　LastRow3 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet3のA列の最後の行の値
'　　　　v3 = .Range("A1:A" & LastRow3).Value 'バリアントに代入
　　
　　'★位置変更により移動
　　'>===【ここから】空白行の検索を最初のものを一部修正し入れてみました。=============
'　　roopflg = True
'　　NewRow = 2　　　　　　　　　 '最初のデータ行
'　　Do While (roopflg = True And NewRow < 65530)　　'最大行数未満の間ループ
'　　　　If Trim(.Cells(NewRow, 1)) = "" Then
'　　　　　　'*****日が空白なので空白行とみなしループを抜ける
'　　　　　　roopflg = False
'　　　　Else
'　　　　　　NewRow = NewRow + 1
'　　　　End If
'　　Loop
'　　　　If (roopflg = True) Then
'　　　　　　MsgBox "入力シートに転記できる行がありません。", vbAbortRetryIgnore, "空白行検索"
'　　　　Exit Sub
'　　　　End If
'
'　　End With
　　'>====【ここまで】==============
　　
　　NewRow = 3
　　With Ws4
　　　　LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'Ws4のA列の最後の行の値
　　　　v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
　　　　For i = 2 To LastRow4
　　　　　　If Me.TextBox1.Text = v4(i, 1) Then '同じ日がある場合、転記操作を行う
　　　　　　　　'>===【ここから】空白行の検索を最初のものを一部修正し入れてみました。===
　　　　　　　　'Sheet3の空き行位置を取得
　　　　　　　　Do While NewRow <= 65530
　　　　　　　　　　If Trim(Ws3.Cells(NewRow, 1).Value) = "" Then
　　　　　　　　　　　　Exit Do
　　　　　　　　　　Else
　　　　　　　　　　　　NewRow = NewRow + 1
　　　　　　　　　　End If
　　　　　　　　Loop
　　　　　　　　If NewRow > 65530 Then
　　　　　　　　　　strPrompt = "入力シートに設定できる行がありません。"
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　　'>====【ここまで】==============
　　　　　　　　'***転記*********************************************************
　　　　　　　　'★行削除の為、代入式右辺の「i」を「i + delRows」に変更
　　　　　　　　Ws3.Range("A" & NewRow).Value = .Range("A" & (i - delRows)).Value
　　　　　　　　Ws3.Range("B" & NewRow).Resize(, 9).Value _
　　　　　　　　　　　　= .Range("C" & (i - delRows)).Resize(, 9).Value
　　　　　　　　Ws3.Range("K" & NewRow).Value = .Range("AC" & (i - delRows)).Value
　　　　　　　　Ws3.Range("M" & NewRow).Value = .Range("X" & (i - delRows)).Value
　　　　　　　　Ws3.Range("N" & NewRow).Value _
　　　　　　　　　　　　= Application.RoundDown(.Range("X" & (i - delRows)).Value _
　　　　　　　　　　　　　　　　/ TextBox2.Text * TextBox3.Text / 1, 0)
　　　　　　　　Ws3.Range("O" & NewRow).Value = .Range("Y" & (i - delRows)).Value
　　　　　　　　Ws3.Range("P" & NewRow).Value _
　　　　　　　　　　　　= Application.RoundDown(.Range("Y" & (i - delRows)).Value _
　　　　　　　　　　　　　　　　/ TextBox4.Text * TextBox5.Text / 1, 0)
　　　　　　　　Ws3.Range("Q" & NewRow).Value = .Range("Z" & (i - delRows)).Value
　　　　　　　　Ws3.Range("R" & NewRow).Value _
　　　　　　　　　　　　= Application.RoundDown(.Range("Z" & (i - delRows)).Value _
　　　　　　　　　　　　　　　　/ TextBox6.Text * TextBox7.Text / 1, 0)
　　　　　　　　Ws3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & (i - delRows)).Value
　　　　　　　　Ws3.Range("T" & NewRow).Value _
　　　　　　　　　　　　= Application.RoundDown(.Range("AA" & (i - delRows)).Value _
　　　　　　　　　　　　　　　　/ TextBox8.Text * TextBox9.Text / 1, 0)
　　　　　　　　Ws3.Range("U" & NewRow).Resize(, 2).Value _
　　　　　　　　　　　　= .Range("AD" & (i - delRows)).Resize(, 2).Value
　　　　　　　　Ws3.Range("L" & NewRow).Value _
　　　　　　　　　　　　= Ws3.Range("N" & NewRow).Value _
　　　　　　　　　　　　+ Ws3.Range("P" & NewRow).Value _
　　　　　　　　　　　　+ Ws3.Range("R" & NewRow).Value _
　　　　　　　　　　　　+ Ws3.Range("T" & NewRow).Value
　　　　　　　　.Rows(i - delRows).Delete　　 '★Sheet4の行を削除
　　　　　　　　NewRow = NewRow + 1　　　　　 '次の代入行へ
　　　　　　　　delRows = delRows + 1　　　　 '削除する回数分の行数を取得
　　　　　　　　'***************************************************************
　　　　　　　　'★Sheet4の整列をさせない為削除
'　　　　　　　　If Me.TextBox1.Text <> v4(i + 1, 1) Then '次の行が異なればループを抜ける
'　　　　　　　　　　delRowEnd = i '終わりの行を取得
'　　　　　　　　　　Exit For
'　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　'★変更
'　　　　If i > LastRow4 Then 'lastrow4を超えてしまったら
'　　　　　　MsgBox "入力された支給日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "支給日エラー"
'　　　　　　Exit Sub
'　　　　End If
　　　　If delRows > 0 Then '★削除行が有った場合
　　　　　　strPrompt = delRows & "件の転記処理が完了しました"
　　　　Else
　　　　　　strPrompt = "入力された支給日は存在しませんでした。確認してください。"
　　　　End If
　　　　'★Sheet4の削除処理をLoop内で行う為、削除
'　　　　If delRows <> 0 Then
'　　　　　　delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
'　　　　　　.Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
'　　　　End If
　　End With
　　
Wayout:

　　Set Ws3 = Nothing
　　Set Ws4 = Nothing

　　MsgBox strPrompt, vbInformation
　　
End Sub

0 hits

▼

【61854】EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/9(火) 14:16