Excel VBA質問箱 IV

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

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


20257 / 76736 ←次へ | 前へ→

【61901】Re:EXCEL VBA 繰返しと計算結果。
発言  Hirofumi  - 09/6/11(木) 15:12 -

引用なし
パスワード
   >  代入のところで値が違います。と出てきます。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 質問
【61860】Re:EXCEL VBA 繰返しと計算結果。 にぃ 09/6/9(火) 16:18 回答
【61862】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/9(火) 16:45 お礼
【61863】Re:EXCEL VBA 繰返しと計算結果。 にぃ 09/6/9(火) 16:52 発言
【61866】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/9(火) 17:29 お礼
【61878】Re:EXCEL VBA 繰返しと計算結果。 にぃ 09/6/10(水) 10:37 発言
【61888】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/10(水) 15:55 お礼
【61898】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/11(木) 11:39 質問
【61899】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/11(木) 14:08 発言
【61902】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/11(木) 16:16 お礼
【61904】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/11(木) 17:35 発言
【61905】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/11(木) 18:34 お礼
【61912】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/11(木) 22:18 発言
【61922】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/12(金) 10:14 お礼
【61924】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/12(金) 10:34 発言
【61901】Re:EXCEL VBA 繰返しと計算結果。 Hirofumi 09/6/11(木) 15:12 発言
【61903】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/11(木) 16:20 お礼
【61919】Re:EXCEL VBA 繰返しと計算結果。 Hirofumi 09/6/12(金) 8:46 発言
【61925】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/12(金) 10:49 お礼
【61935】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/12(金) 22:21 回答
【61968】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/15(月) 15:03 お礼
【61934】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/12(金) 17:34 質問
【61936】Re:EXCEL VBA 繰返しと計算結果。 Hirofumi 09/6/12(金) 23:56 回答
【61938】Re:EXCEL VBA 繰返しと計算結果。 Hirofumi 09/6/13(土) 8:59 回答
【61963】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/15(月) 10:19 お礼
【61861】Re:EXCEL VBA 繰返しと計算結果。 neptune 09/6/9(火) 16:30 発言
【61864】Re:EXCEL VBA 繰返しと計算結果。 おねがいします。 09/6/9(火) 17:01 お礼

20257 / 76736 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free