| |
▼にぃ さん：
▼Hirofumi さん：
▼neptune さん：
こんにちは。お世話になります。
下記のような変更＋してみました。最後のところでエラーが出てしまいます。
申し訳ありまあせんが、宜しくお願いします。
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
Set Ws3 = Sheet3
Set Ws4 = Sheet4
If (Me.TextBox1.Text = "") Then
MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
Exit Sub
End If
With Ws3
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
>====【ここまで】==============
With Ws4
LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet4のA列の最後の行の値
v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
For I = 2 To LastRow4
If Me.TextBox1.Text = v4(I, 1) Then '同じ日がある場合、転記操作を行う
'***転記*********************************************************************************************
Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
Sheet3.Range("B" & NewRow).Resize(, 9).Value = .Range("C" & I).Resize(, 9).Value
Sheet3.Range("K" & NewRow).Value = .Range("AC" & I).Value
Sheet3.Range("M" & NewRow).Value = .Range("X" & I).Value
Sheet3.Range("N" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
(.Range("X" & I).Value / TextBox2.Text * TextBox3.Text) / 1, 0)
Sheet3.Range("O" & NewRow).Value = .Range("Y" & I).Value
Sheet3.Range("P" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
(.Range("Y" & I).Value / TextBox4.Text * TextBox5.Text) / 1, 0)
Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
Sheet3.Range("R" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
(.Range("Z" & I).Value / TextBox6.Text * TextBox7.Text) / 1, 0)
Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
Sheet3.Range("T" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
(.Range("AA" & I).Value / TextBox8.Text * TextBox9.Text) / 1, 0)
Sheet3.Range("U" & NewRow).Resize(, 2).Value = .Range("AD" & I).Resize(, 2).Value
Sheet3.Range("L" & NewRow).Value = Sheet3.Range("N" & NewRow).Value + _
Sheet3.Range("P" & NewRow).Value + Sheet3.Range("R" & NewRow).Value + Sheet3.Range("T" & NewRow).Value
NewRow = NewRow + 1 '次の代入行へ
delRows = delRows + 1 '削除する回数分の行数を取得
'****************************************************************************************************
>ここで◆エラーになります。
> ◆↓v4(I + 1, 1)<インデックスが有効な範囲にありません>
>=========◆→ If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
delRowEnd = I '終わりの行を取得
Exit For
End If
End If
Next
If I > LastRow4 Then 'lastrow4を超えてしまったら
MsgBox "入力された支給日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "支給日エラー"
Exit Sub
End If
If delRows <> 0 Then
delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
.Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
End If
End With
Set Ws3 = Nothing
Set Ws4 = Nothing
End Sub
>試行錯誤しながら、コンパイルチェックしてみてるんですが先に進めません。
>転記までの部分は上手く動いてくれています。が、roopflg のところで何か不都合が
>ありましたらご指摘お願いします。
|
|
おねがいします。
- 09/6/12(金) 17:34 -
