| |
▼おねがいします。 さん：
こんにちは！
>Do を↓で上手くいきました。ありがとうございました。
すみません、最初のDoの位置ですと「NewRow = NewRow + 1」
を入れるのを忘れていたため動作しませんでしたね^^;
>勉強しながらと言うか、ツギハギで作り込んでるので自身が無いんですが
>おかしい(変)所があれば指摘も御願いします。
私もそれほど言える立場ではないのですが、少し言わせていただければ、
RangeやCellsがたくさんありますが、どちらかに統一したほうがいいと思います。
自分だけが見ていればあまり問題ないですが、他の人がみたり、編集したり、
またこのような掲示板で載せる場合にも統一していたほうが見やすく
分析しやすいです。
あとは転機の際にしっかりと「Sheet3」や「Sheet4」を宣言しているので
いちいちSheetをActiveにする必要はないです。
一応下記に少し改善して作ってみましたが、もっといい方法はたくさん
あると思います。参考程度に使ってやってください。
ちなみに比較の際にVariantで置き換えて操作したほうが処理が速くなるので
使用しました。
Variantはとてもいい機能なので機会があったら調べてみてください。
また、動作テストは行ってませんので、テスト環境でこちらは行ってください。
コード的には短くなってないかもしれませんが、処理スピードは速くなっているはずです。
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 'バリアントに代入
For I = 3 To LastRow3
If Trim(v3(I, 1)) = "" Then '空白行がある場合
I = NewRow
Exit For
End If
Next
If I > LastRow3 Then ''lastrow3を超えてしまったら
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 / 21 * 35) / 1, 0)
Sheet3.Range("O" & NewRow).Resize(, 2).Value = .Range("Y" & I).Value
Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
Sheet3.Range("R" & NewRow).Value = Application.RoundDown _
(Application.WorksheetFunction.Sum(.Range("Z" & I).Value / 4 * 7) / 1, 0)
Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
Sheet3.Range("W" & 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 + _
Sheet3.Range("V" & NewRow).Value
NewRow = NewRow + 1 '次の代入行へ
delRows = delRows + 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
|
|
にぃ
- 09/6/10(水) 10:37 -
