Excel VBA質問箱 IV

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

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


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

20255 / 76736

←次へ　｜　前へ→


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

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


	引用なし

	パスワード

Hirofumi さん

こんにちは。

>>　　代入のところで値が違います。と出てきます。If Trim(v3(I, 1))
>>　　そこで、LastRow3 = .Range & v3 = .Range の前に Ws3.Range としてみたり
>>　　↓不等号を < に変えてみたり色々と試してみたんですが、
>>　　［"入力シートに設定できる行がありません。"］または、転記操作の
>>　　Sheet3.Range("A" & NewRow) で [NewRow=0] となります。
>
>多分、
>　　　　　　　　I = NewRow
>が
>　　　　　　　　NewRow = I
>の様な気がします
>
>ついでに、コードをざっと見て行った時に
>元のコードの解釈が違う様な気がしますので
>私成りに書いて見ました
>ただ、サンプルデータが無いので（作るのも面倒なので）Testはして居ません
>間違っていたらゴメン

ありがとうございます。

>
>Option Explicit
>
>Private Sub CommandButton1_Click()
>　
>　　Dim i As Long
>　　Dim j As Long
>　　Dim vntDate As Variant
>　　Dim strPrompt As String
>　　Dim Ws3 As Worksheet
>　　Dim Ws4 As Worksheet
>　　Dim lngFound As Long
>　　Dim vntList As Variant
>　　Dim vntResult As Variant
>　　Dim vntFrom As Variant
>　　Dim vntTo As Variant
>　　Dim lngRows As Long
>　　Dim NewRow As Long
>　　
>　　Set Ws3 = Sheet3
>　　Set Ws4 = Sheet4
>　　
>　　vntDate = Me.TextBox1.Text
>　　
>　　If vntDate = "" Then
>　　　　strPrompt = "*****日を入力してください。"
>　　　　GoTo Wayout
>　　End If
>　
>　　'転記先の列番号を列挙
>　　vntTo = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, _
>　　　　　　　　　　11, 13, 14, 15, 16, 17, 18, 19, 20, 23, 24)
>　　'転記元の列番号を列強
>　　'"A","C","D","E","F","G","H","I","J","K","AC"
>　　',"X","X","Y","Y","Z","Z","AA","AA","AD","AE"の順で
>　　vntFrom = Array(1, 3, 4, 5, 6, 7, 8, 9, 10, _
>　　　　　　　　　　11, 29, 24, 24, 25, 25, 26, 26, 27, 27, 30, 31)
>　　
>　　'Sheet4のA列最終行を取得
>　　If IsEmpty(Ws4.Cells(Rows.Count, 1).Value) Then
>　　　　lngRows = Ws4.Cells(Rows.Count, 1).End(xlUp).Row
>　　Else
>　　　　lngRows = Rows.Count
>　　End If
>　　
>　　lngFound = 2
>　　NewRow = 3
>　　'Sheet4A列でTextBox1と同じ日付の有る行を探索
>　　Do While lngFound <= lngRows
>　　　　If Ws4.Cells(lngFound, 1).Value = vntDate Then
>　　　　　　'Sheet3の空き行位置を取得
>　　　　　　Do While NewRow <= Rows.Count
>　　　　　　　　If Trim(Ws3.Cells(NewRow, 1).Value) = "" Then
>　　　　　　　　　　Exit Do
>　　　　　　　　Else
>　　　　　　　　　　NewRow = NewRow + 1
>　　　　　　　　End If
>　　　　　　Loop
>　　　　　　If NewRow > Rows.Count Then
>　　　　　　　　strPrompt = "入力シートに設定できる行がありません。"
>　　　　　　　　GoTo Wayout
>　　　　　　End If
>　　　　　　'転記先データ行を配列に取得
>　　　　　　vntResult = Ws3.Cells(NewRow, 1).Resize(, 24).Value
>　　　　　　'転記元データ行を配列に取得
>　　　　　　vntList = Ws4.Cells(lngFound, 1).Resize(, 31).Value
>　　　　　　'データを転記
>　　　　　　For i = 0 To UBound(vntFrom)
>　　　　　　　　vntResult(1, vntTo(i)) = vntList(1, vntFrom(i))
>　　　　　　Next i
>　　　　　　vntResult(1, 14) = Sgn(vntResult(1, 14)) * Int(Abs(vntResult(1, 14)) / 21 * 35)
>　　　　　　vntResult(1, 18) = Sgn(vntResult(1, 18)) * Int(Abs(vntResult(1, 18)) / 4 * 7)
>　　　　　　For i = 14 To 22 Step 2
>　　　　　　　　vntResult(1, 12) = vntResult(1, 12) + vntResult(1, i)
>　　　　　　Next i
>　　　　　　'更新データをシートに出力
>　　　　　　Ws3.Cells(NewRow, 1).Resize(, 24).Value = vntResult
>　　　　　　'転記元行を削除
>　　　　　　Ws4.Rows(lngFound).Delete Shift:=xlUp
>　　　　　　'データ転記　★上記コードで代用
>'　　　　　　With Ws4
>'　　　　　　　　Ws3.Cells(NewRow, 1).Value = .Range("A" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 2).Value = .Range("C" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 3).Value = .Range("D" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 4).Value = .Range("E" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 5).Value = .Range("F" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 6).Value = .Range("G" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 7).Value = .Range("H" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 8).Value = .Range("I" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 9).Value = .Range("J" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 10).Value = .Range("K" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 11).Value = .Range("AC" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 13).Value = .Range("X" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 14).Value _
>'　　　　　　　　　　　　= Application.RoundDown(.Range("X" & lngFound).Value / 21 * 35, 0)
>'　　　　　　　　Ws3.Cells(NewRow, 15).Value = .Range("Y" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 16).Value = .Range("Y" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 17).Value = .Range("Z" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 18).Value _
>'　　　　　　　　　　　　= Application.RoundDown(.Range("Z" & lngFound).Value / 4 * 7, 0)
>'　　　　　　　　Ws3.Cells(NewRow, 19).Value = .Range("AA" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 20).Value = .Range("AA" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 23).Value = .Range("AD" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 24).Value = .Range("AE" & lngFound).Value
>'　　　　　　　　Ws3.Cells(NewRow, 12).Value = Ws3.Cells(NewRow, 14).Value _
>'　　　　　　　　　　　　　　　　　　　　　　+ Ws3.Cells(NewRow, 16).Value _
>'　　　　　　　　　　　　　　　　　　　　　　+ Ws3.Cells(NewRow, 18).Value _
>'　　　　　　　　　　　　　　　　　　　　　　+ Ws3.Cells(NewRow, 20).Value _
>'　　　　　　　　　　　　　　　　　　　　　　+ Ws3.Cells(NewRow, 22).Value
>'　　　　　　　　.Rows(lngFound).Delete Shift:=xlUp
>'　　　　　　End With
>　　　　　　'行データ削除により最終行を1つ減らす
>　　　　　　lngRows = lngRows - 1
>　　　　　　'次の空白行探す為、1行下へ
>　　　　　　NewRow = NewRow + 1
>　　　　Else
>　　　　　　lngFound = lngFound + 1
>　　　　End If
>　　Loop
>　　
>　　strPrompt = "日付列行末に達しましたので終了します"
>
>Wayout:
>
>　　Set Ws3 = Nothing
>　　Set Ws4 = Nothing
>
>　　MsgBox strPrompt, vbInformation
>
>End Sub

早速やってみます。ホントにありがとうございます。

0 hits

▼

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