Excel VBA質問箱 IV

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

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


20222 / 76736 ←次へ | 前へ→

【61936】Re:EXCEL VBA 繰返しと計算結果。
回答  Hirofumi  - 09/6/12(金) 23:56 -

引用なし
パスワード
   >>ここで◆エラーになります。
>>                   ◆↓v4(I + 1, 1)<インデックスが有効な範囲にありません>
>>=========◆→  If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
>          delRowEnd = I '終わりの行を取得
>          Exit For
>        End If
>      End If


このエラーの回避だけで言うなら簡単なのですが?

v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入



v4 = .Range("A1:A" & (LastRow4 + 1)).Value 'バリアントに代入

とすれば善いだけですが

もっと基本的に直すと(詳しくTestして居ませんが)以下の様にした方が善い様なきがします

Option Explicit

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
  Dim strPrompt As String
  
  Set Ws3 = Sheet3
  Set Ws4 = Sheet4

  If Me.TextBox1.Text = "" Then
    strPrompt = "*****日を入力してください。"
    GoTo Wayout
  End If

'  With Ws3
    '★LastRow3、v3を使って居ないので削除
'    LastRow3 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet3のA列の最後の行の値
'    v3 = .Range("A1:A" & LastRow3).Value 'バリアントに代入
  
  '★位置変更により移動
  '>===【ここから】空白行の検索を最初のものを一部修正し入れてみました。=============
'  roopflg = True
'  NewRow = 2          '最初のデータ行
'  Do While (roopflg = True And NewRow < 65530)  '最大行数未満の間ループ
'    If Trim(.Cells(NewRow, 1)) = "" Then
'      '*****日が空白なので空白行とみなしループを抜ける
'      roopflg = False
'    Else
'      NewRow = NewRow + 1
'    End If
'  Loop
'    If (roopflg = True) Then
'      MsgBox "入力シートに転記できる行がありません。", vbAbortRetryIgnore, "空白行検索"
'    Exit Sub
'    End If
'
'  End With
  '>====【ここまで】==============
  
  NewRow = 3
  With Ws4
    LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'Ws4のA列の最後の行の値
    v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
    For i = 2 To LastRow4
      If Me.TextBox1.Text = v4(i, 1) Then '同じ日がある場合、転記操作を行う
        '>===【ここから】空白行の検索を最初のものを一部修正し入れてみました。===
        'Sheet3の空き行位置を取得
        Do While NewRow <= 65530
          If Trim(Ws3.Cells(NewRow, 1).Value) = "" Then
            Exit Do
          Else
            NewRow = NewRow + 1
          End If
        Loop
        If NewRow > 65530 Then
          strPrompt = "入力シートに設定できる行がありません。"
          Exit For
        End If
        '>====【ここまで】==============
        '***転記*********************************************************
        '★行削除の為、代入式右辺の「i」を「i + delRows」に変更
        Ws3.Range("A" & NewRow).Value = .Range("A" & (i - delRows)).Value
        Ws3.Range("B" & NewRow).Resize(, 9).Value _
            = .Range("C" & (i - delRows)).Resize(, 9).Value
        Ws3.Range("K" & NewRow).Value = .Range("AC" & (i - delRows)).Value
        Ws3.Range("M" & NewRow).Value = .Range("X" & (i - delRows)).Value
        Ws3.Range("N" & NewRow).Value _
            = Application.RoundDown(.Range("X" & (i - delRows)).Value _
                / TextBox2.Text * TextBox3.Text / 1, 0)
        Ws3.Range("O" & NewRow).Value = .Range("Y" & (i - delRows)).Value
        Ws3.Range("P" & NewRow).Value _
            = Application.RoundDown(.Range("Y" & (i - delRows)).Value _
                / TextBox4.Text * TextBox5.Text / 1, 0)
        Ws3.Range("Q" & NewRow).Value = .Range("Z" & (i - delRows)).Value
        Ws3.Range("R" & NewRow).Value _
            = Application.RoundDown(.Range("Z" & (i - delRows)).Value _
                / TextBox6.Text * TextBox7.Text / 1, 0)
        Ws3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & (i - delRows)).Value
        Ws3.Range("T" & NewRow).Value _
            = Application.RoundDown(.Range("AA" & (i - delRows)).Value _
                / TextBox8.Text * TextBox9.Text / 1, 0)
        Ws3.Range("U" & NewRow).Resize(, 2).Value _
            = .Range("AD" & (i - delRows)).Resize(, 2).Value
        Ws3.Range("L" & NewRow).Value _
            = Ws3.Range("N" & NewRow).Value _
            + Ws3.Range("P" & NewRow).Value _
            + Ws3.Range("R" & NewRow).Value _
            + Ws3.Range("T" & NewRow).Value
        .Rows(i - delRows).Delete   '★Sheet4の行を削除
        NewRow = NewRow + 1      '次の代入行へ
        delRows = delRows + 1     '削除する回数分の行数を取得
        '***************************************************************
        '★Sheet4の整列をさせない為削除
'        If Me.TextBox1.Text <> v4(i + 1, 1) Then '次の行が異なればループを抜ける
'          delRowEnd = i '終わりの行を取得
'          Exit For
'        End If
      End If
    Next i
    '★変更
'    If i > LastRow4 Then 'lastrow4を超えてしまったら
'      MsgBox "入力された支給日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "支給日エラー"
'      Exit Sub
'    End If
    If delRows > 0 Then '★削除行が有った場合
      strPrompt = delRows & "件の転記処理が完了しました"
    Else
      strPrompt = "入力された支給日は存在しませんでした。確認してください。"
    End If
    '★Sheet4の削除処理をLoop内で行う為、削除
'    If delRows <> 0 Then
'      delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
'      .Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
'    End If
  End With
  
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 お礼

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