| |
> 代入のところで値が違います。と出てきます。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
|
|
Hirofumi
- 09/6/11(木) 15:12 -
