Excel VBA質問箱 IV

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

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


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

20260 / 76736

←次へ　｜　前へ→


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

おねがいします。 - 09/6/11(木) 11:39 -


	引用なし

	パスワード

▼にぃ様

こんにちは。お世話になってます。
先日はありがとうございました。

先日から早速試しているんですが、躓いてます。助けてください。

>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 Trim(v3(I, 1))
　　そこで、LastRow3 = .Range & v3 = .Range の前に Ws3.Range としてみたり
　　↓不等号を < に変えてみたり色々と試してみたんですが、
　　［"入力シートに設定できる行がありません。"］または、転記操作の
　　Sheet3.Range("A" & NewRow) で [NewRow=0] となります。

　　試練を与えて頂いたと思い色々と調べてみたんですが、分かりませんでした。

　　申し訳ありませんが、引き続きお願い出来ないでしょうか？
　　宜しくお願いします。

>　　　　
>　　　　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

0 hits

▼

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