| |
▼おねがいします。 さん：
見にくかったので、少しだけ見易くしました。全体としては変更してません。
問題部分だけしか見てないし、検証もしておりませんので
検証願います。もし動いたら無駄変数の確認もしてください。
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 Ws4 = Sheet4
If ChkData = False Then Exit Sub
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 I + 1 <= LastRow4 Then 'インデックスが有効な範囲である事を確認
If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
delRowEnd = I '終わりの行を取得
Exit For
End If
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 Ws4 = Nothing
End Sub
Private Function ChkData() As Boolean
Const sWorkSheetName As String = "Sheet3"
Dim Ws3 As Worksheet
Dim LastRow3 As Long, NewRow As Long
Dim roopflg As Boolean
Set Ws3 = Worksheets(sWorkSheetName)
If (Me.TextBox1.Text = "") Then
MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
ChkData = False
Exit Function
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, "空白行検索"
ChkData = False
Exit Function
End If
End With
'>====【ここまで】==============
ChkData = True
End Function
|
|
neptune
- 09/6/12(金) 22:21 -
