|
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
早速やってみます。ホントにありがとうございます。
|
|