Excel VBA質問箱 IV

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

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


3479 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   お手数ですが宜しくお願い致します。

マルチになってしまいます。
答えてネットに同じ質問をしていますが、回答が得られず困ってます。

まず、別のエクセルファイルからデータを取り込みます。(←ここは別途)
取り込んだデータ(約200件分)を集計/転記するんですが、

1.Sheet3.Cells(NewRow, 12) に (NewRow, 14)(NewRow, 16)(NewRow, 18)(NewRow, 20)(NewRow, 22)の合計を転記させたい。

2.1件処理する毎に CommandButton1 を 1回押さなくてはいけない。
  (同"日"分は纏めて処理したい。)

3.他(最善)の方法が別にあれば教えてください。

宜しくお願いします。

__________________________________
Private Sub CommandButton1_Click()
  
  Dim I As Long
  Dim doendFLG As Boolean
  Dim IR As String
  
  If (Me.TextBox1.Text = "") Then
    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
    Exit Sub
  End If
  
  I = 2
  doendFLG = False
  Do While (I <= 65535 And doendFLG = False)
    If (Sheet4.Cells(I, 1) = Me.TextBox1.Text) Then
      doendFLG = True
    Else
      I = I + 1
    End If
  Loop
  If (doendFLG = False) Then
    MsgBox "入力された*****日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "*****日エラー"
    Exit Sub
  End If
  
  roopflg = True
  NewRow = 3
  Do While (roopflg = True And NewRow < 65530)
    If Trim(Sheet3.Cells(NewRow, 1)) = "" Then
      roopflg = False
    Else
      NewRow = NewRow + 1
    End If
  Loop
  If (roopflg = True) Then
    MsgBox "入力シートに設定できる行がありません。", vbAbortRetryIgnore, "空白行検索"
    Exit Sub
  End If
    
  Call Sheet3.Activate
    Sheet3.Cells(NewRow, 1) = Sheet4.Range("A" & CStr(I))
    Sheet3.Cells(NewRow, 2) = Sheet4.Range("C" & CStr(I))
    Sheet3.Cells(NewRow, 3) = Sheet4.Range("D" & CStr(I))
    Sheet3.Cells(NewRow, 4) = Sheet4.Range("E" & CStr(I))
    Sheet3.Cells(NewRow, 5) = Sheet4.Range("F" & CStr(I))
    Sheet3.Cells(NewRow, 6) = Sheet4.Range("G" & CStr(I))
    Sheet3.Cells(NewRow, 7) = Sheet4.Range("H" & CStr(I))
    Sheet3.Cells(NewRow, 8) = Sheet4.Range("I" & CStr(I))
    Sheet3.Cells(NewRow, 9) = Sheet4.Range("J" & CStr(I))
    Sheet3.Cells(NewRow, 10) = Sheet4.Range("K" & CStr(I))
    Sheet3.Cells(NewRow, 11) = Sheet4.Range("AC" & CStr(I))
    Sheet3.Cells(NewRow, 13) = Sheet4.Range("X" & CStr(I))
    Sheet3.Cells(NewRow, 14) = Application.RoundDown _
    (Application.WorksheetFunction.Sum(Sheet4.Range("X" & CStr(I)) / 21 * 35) / 1, 0)
    Sheet3.Cells(NewRow, 15) = Sheet4.Range("Y" & CStr(I))
    Sheet3.Cells(NewRow, 16) = Sheet4.Range("Y" & CStr(I))
    Sheet3.Cells(NewRow, 17) = Sheet4.Range("Z" & CStr(I))
    Sheet3.Cells(NewRow, 18) = Application.RoundDown _
    (Application.WorksheetFunction.Sum(Sheet4.Range("Z" & CStr(I)) / 4 * 7) / 1, 0)
    Sheet3.Cells(NewRow, 19) = Sheet4.Range("AA" & CStr(I))
    Sheet3.Cells(NewRow, 20) = Sheet4.Range("AA" & CStr(I))
    Sheet3.Cells(NewRow, 23) = Sheet4.Range("AD" & CStr(I))
    Sheet3.Cells(NewRow, 24) = Sheet4.Range("AE" & CStr(I))
    
  Call Sheet4.Activate
    Rows(CStr(I)).Select
      Selection.Delete Shift:=xlUp

End Sub
 ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄

【61860】Re:EXCEL VBA 繰返しと計算結果。
回答  にぃ  - 09/6/9(火) 16:18 -

引用なし
パスワード
   ▼おねがいします。 さん:
こんにちは!

>マルチになってしまいます。
>答えてネットに同じ質問をしていますが、回答が得られず困ってます。
確かこちらではマルチ禁止?となっていたような気がしますので
もうひとつのほうは閉じることをおすすめします。

>1.Sheet3.Cells(NewRow, 12) に (NewRow, 14)(NewRow, 16)(NewRow, 18)(NewRow, 20)(NewRow, 22)の合計を転記させたい。
>
>2.1件処理する毎に CommandButton1 を 1回押さなくてはいけない。
>  (同"日"分は纏めて処理したい。)

とりあえず今の状況でこちらの1と2を追加してみました。
テストは行っていません。


>3.他(最善)の方法が別にあれば教えてください。

こちらは何かいい方法が思いついたらやってみたいと思います^^

ちなみに、「.Value」は省略させないほうがいいですよ。

>__________________________________
>Private Sub CommandButton1_Click()
>  
>  Dim I As Long
>  Dim doendFLG As Boolean
>  Dim IR As String
>  
>  If (Me.TextBox1.Text = "") Then
>    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
>    Exit Sub
>  End If
>  
>  I = 2
>  doendFLG = False
>  Do While (I <= 65535 And doendFLG = False)
>    If (Sheet4.Cells(I, 1) = Me.TextBox1.Text) Then
>      doendFLG = True
>    Else
>      I = I + 1
>    End If
>  Loop
>  If (doendFLG = False) Then
>    MsgBox "入力された*****日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "*****日エラー"
>    Exit Sub
>  End If
>  
>  roopflg = True
>  NewRow = 3
>  Do While (roopflg = True And NewRow < 65530)
>    If Trim(Sheet3.Cells(NewRow, 1)) = "" Then
>      roopflg = False
>    Else
>      NewRow = NewRow + 1
>    End If
>  Loop
>  If (roopflg = True) Then
>    MsgBox "入力シートに設定できる行がありません。", vbAbortRetryIgnore, "空白行検索"
>    Exit Sub
>  End If
>    

   Do

>  Call Sheet3.Activate
>    Sheet3.Cells(NewRow, 1) = Sheet4.Range("A" & CStr(I))
>    Sheet3.Cells(NewRow, 2) = Sheet4.Range("C" & CStr(I))
>    Sheet3.Cells(NewRow, 3) = Sheet4.Range("D" & CStr(I))
>    Sheet3.Cells(NewRow, 4) = Sheet4.Range("E" & CStr(I))
>    Sheet3.Cells(NewRow, 5) = Sheet4.Range("F" & CStr(I))
>    Sheet3.Cells(NewRow, 6) = Sheet4.Range("G" & CStr(I))
>    Sheet3.Cells(NewRow, 7) = Sheet4.Range("H" & CStr(I))
>    Sheet3.Cells(NewRow, 8) = Sheet4.Range("I" & CStr(I))
>    Sheet3.Cells(NewRow, 9) = Sheet4.Range("J" & CStr(I))
>    Sheet3.Cells(NewRow, 10) = Sheet4.Range("K" & CStr(I))
>    Sheet3.Cells(NewRow, 11) = Sheet4.Range("AC" & CStr(I))
>    Sheet3.Cells(NewRow, 13) = Sheet4.Range("X" & CStr(I))
>    Sheet3.Cells(NewRow, 14) = Application.RoundDown _
>    (Application.WorksheetFunction.Sum(Sheet4.Range("X" & CStr(I)) / 21 * 35) / 1, 0)
>    Sheet3.Cells(NewRow, 15) = Sheet4.Range("Y" & CStr(I))
>    Sheet3.Cells(NewRow, 16) = Sheet4.Range("Y" & CStr(I))
>    Sheet3.Cells(NewRow, 17) = Sheet4.Range("Z" & CStr(I))
>    Sheet3.Cells(NewRow, 18) = Application.RoundDown _
>    (Application.WorksheetFunction.Sum(Sheet4.Range("Z" & CStr(I)) / 4 * 7) / 1, 0)
>    Sheet3.Cells(NewRow, 19) = Sheet4.Range("AA" & CStr(I))
>    Sheet3.Cells(NewRow, 20) = Sheet4.Range("AA" & CStr(I))
>    Sheet3.Cells(NewRow, 23) = Sheet4.Range("AD" & CStr(I))
>    Sheet3.Cells(NewRow, 24) = Sheet4.Range("AE" & CStr(I))
>    
     With Sheet3.Cells(NewRow, 12)
      .Value = .Offset(, 2).Value + .Offset(, 4).Value + .Offset(, 6).Value _
          + .Offset(, 8).Value + .Offset(, 10).Value
    End With

>  Call Sheet4.Activate
>    Rows(CStr(I)).Select
>      Selection.Delete Shift:=xlUp
>
   If Sheet4.Range("A" & I).Value <> Me.TextBox1.Text Then '転記させた行は削除しているようなので
      Exit Do                       'Iは同じ数字で比較する
    End If                          '異なる場合ループを抜ける
  Loop

>End Sub
> ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄

【61861】Re:EXCEL VBA 繰返しと計算結果。
発言  neptune  - 09/6/9(火) 16:30 -

引用なし
パスワード
   ▼おねがいします。 さん:

回答ではありません。

>マルチになってしまいます。
>答えてネットに同じ質問をしていますが、回答が得られず困ってます。
この掲示板はマルチ先がマルチを禁じてないなら問題ないルールですよ。

質問ですが、このプログラムはご自分で書いたものですか?
もしそうなら、具体的に何が判らないのでしょうか?

>1.Sheet3.Cells(NewRow, 12) に (NewRow, 14)(NewRow, 16)(NewRow, 18)(NewRow, 20)(NewRow, 22)の合計を転記させたい。
ただ、足し算をするだけと思いますが。何が判らないのでしょう?

>2.1件処理する毎に CommandButton1 を 1回押さなくてはいけない。
>  (同"日"分は纏めて処理したい。)
全部細かく読んで、考えるのが面倒なので、
・恐らく後でまた聞かなければならないユーザーインターフェイスについての説明
・プログラム中の小さな塊にコメントが欲しい

>取り込んだデータ(約200件分)を集計/転記するんですが、
基本は1件1件地道に処理する事です。
なので、1件1件地道に処理する関数をつくり、それに必要な引数を持たせ
CommandButton1から必要な回数だけその関数を呼び出すのが普通と思います。

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

引用なし
パスワード
   にぃ 様。ありがとうございます。

早速反映してみます。結果については、こちらに投稿させて頂きます。

マルチについては、一応基本方針を確認しましたが、[原則許可]でしたので
答えてネットの方もそのままにしてありましたが先程、[未解決で終了?]
しました。

これまでに作ったものやネットで探したり、マニュアル片手に見よう見まねで
なんとかここまで来ました。

お手数をお掛けしますが、宜しければ引き続き宜しくお願い致します。

【61863】Re:EXCEL VBA 繰返しと計算結果。
発言  にぃ  - 09/6/9(火) 16:52 -

引用なし
パスワード
   ▼おねがいします。 さん:
こんにちは!

>マルチについては、一応基本方針を確認しましたが、[原則許可]でしたので
>答えてネットの方もそのままにしてありましたが先程、[未解決で終了?]
>しました。

失礼しましたm(__)m「原則許可」でしたね^^;

【61864】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/9(火) 17:01 -

引用なし
パスワード
   ▼neptune 様。ありがとうございます

>>マルチになってしまいます。
>>答えてネットに同じ質問をしていますが、回答が得られず困ってます。
>この掲示板はマルチ先がマルチを禁じてないなら問題ないルールですよ。

一応、[未解決で終了]しました。ありがとうございます。

>質問ですが、このプログラムはご自分で書いたものですか?
>もしそうなら、具体的に何が判らないのでしょうか?

一応そうです。一応と言うのは、過去に作成したものだったり
マニュアル(できるシリーズ)だったり、色々と引用しながら
書きました。

>>1.Sheet3.Cells(NewRow, 12) に (NewRow, 14)(NewRow, 16)(NewRow, 18)(NewRow, 20)(NewRow, 22)の合計を転記させたい。
>ただ、足し算をするだけと思いますが。何が判らないのでしょう?

(NewRow, 14)(NewRow, 18)には、Sheet4.Range"X",Sheet4.Range"Z" の計算結果を
設定しているため、Sheet4.Range"X",Sheet4.Range"Z" の集計結果の
(NewRow, 14)(NewRow, 18)とSheet4.Range"Y",Sheet4.Range"AA" の合計を
Sheet3.Cells(NewRow, 12) に設定したいんです。(分かり辛いですね。)

>>2.1件処理する毎に CommandButton1 を 1回押さなくてはいけない。
>>  (同"日"分は纏めて処理したい。)
>全部細かく読んで、考えるのが面倒なので、
>・恐らく後でまた聞かなければならないユーザーインターフェイスについての説明
>・プログラム中の小さな塊にコメントが欲しい

コメント等付けていたんですが、掲示(投稿)用に消しました。

>>取り込んだデータ(約200件分)を集計/転記するんですが、
>基本は1件1件地道に処理する事です。
>なので、1件1件地道に処理する関数をつくり、それに必要な引数を持たせ
>CommandButton1から必要な回数だけその関数を呼び出すのが普通と思います。

勉強します。

【61866】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/9(火) 17:29 -

引用なし
パスワード
   ▼にぃ 様。

Do を↓で上手くいきました。ありがとうございました。

勉強しながらと言うか、ツギハギで作り込んでるので自身が無いんですが
おかしい(変)所があれば指摘も御願いします。

>
>>3.他(最善)の方法が別にあれば教えてください。
>
>こちらは何かいい方法が思いついたらやってみたいと思います^^
>

期待大です。。。。。^^;;


>>__________________________________
>>Private Sub CommandButton1_Click()
>>  
>>  Dim I As Long
>>  Dim doendFLG As Boolean
>>  Dim IR As String
>>  
>>  If (Me.TextBox1.Text = "") Then
>>    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
>>    Exit Sub
>>  End If
>>  
>>  I = 2
>>  doendFLG = False
>>  Do While (I <= 65535 And doendFLG = False)
>>    If (Sheet4.Cells(I, 1) = Me.TextBox1.Text) Then
>>      doendFLG = True
>>    Else
>>      I = I + 1
>>    End If
>>  Loop
>>  If (doendFLG = False) Then
>>    MsgBox "入力された*****日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "*****日エラー"
>>    Exit Sub
>>  End If

   Do

>>  roopflg = True
>>  NewRow = 3
>>  Do While (roopflg = True And NewRow < 65530)
>>    If Trim(Sheet3.Cells(NewRow, 1)) = "" Then
>>      roopflg = False
>>    Else
>>      NewRow = NewRow + 1
>>    End If
>>  Loop
>>  If (roopflg = True) Then
>>    MsgBox "入力シートに設定できる行がありません。", vbAbortRetryIgnore, "空白行検索"
>>    Exit Sub
>>  End If
>>    
>
>   Do
>
>>  Call Sheet3.Activate
>>    Sheet3.Cells(NewRow, 1) = Sheet4.Range("A" & CStr(I))
>>    Sheet3.Cells(NewRow, 2) = Sheet4.Range("C" & CStr(I))
>>    Sheet3.Cells(NewRow, 3) = Sheet4.Range("D" & CStr(I))
>>    Sheet3.Cells(NewRow, 4) = Sheet4.Range("E" & CStr(I))
>>    Sheet3.Cells(NewRow, 5) = Sheet4.Range("F" & CStr(I))
>>    Sheet3.Cells(NewRow, 6) = Sheet4.Range("G" & CStr(I))
>>    Sheet3.Cells(NewRow, 7) = Sheet4.Range("H" & CStr(I))
>>    Sheet3.Cells(NewRow, 8) = Sheet4.Range("I" & CStr(I))
>>    Sheet3.Cells(NewRow, 9) = Sheet4.Range("J" & CStr(I))
>>    Sheet3.Cells(NewRow, 10) = Sheet4.Range("K" & CStr(I))
>>    Sheet3.Cells(NewRow, 11) = Sheet4.Range("AC" & CStr(I))
>>    Sheet3.Cells(NewRow, 13) = Sheet4.Range("X" & CStr(I))
>>    Sheet3.Cells(NewRow, 14) = Application.RoundDown _
>>    (Application.WorksheetFunction.Sum(Sheet4.Range("X" & CStr(I)) / 21 * 35) / 1, 0)
>>    Sheet3.Cells(NewRow, 15) = Sheet4.Range("Y" & CStr(I))
>>    Sheet3.Cells(NewRow, 16) = Sheet4.Range("Y" & CStr(I))
>>    Sheet3.Cells(NewRow, 17) = Sheet4.Range("Z" & CStr(I))
>>    Sheet3.Cells(NewRow, 18) = Application.RoundDown _
>>    (Application.WorksheetFunction.Sum(Sheet4.Range("Z" & CStr(I)) / 4 * 7) / 1, 0)
>>    Sheet3.Cells(NewRow, 19) = Sheet4.Range("AA" & CStr(I))
>>    Sheet3.Cells(NewRow, 20) = Sheet4.Range("AA" & CStr(I))
>>    Sheet3.Cells(NewRow, 23) = Sheet4.Range("AD" & CStr(I))
>>    Sheet3.Cells(NewRow, 24) = Sheet4.Range("AE" & CStr(I))
>>    
>     With Sheet3.Cells(NewRow, 12)
>      .Value = .Offset(, 2).Value + .Offset(, 4).Value + .Offset(, 6).Value _
>          + .Offset(, 8).Value + .Offset(, 10).Value
>    End With
>
>>  Call Sheet4.Activate
>>    Rows(CStr(I)).Select
>>      Selection.Delete Shift:=xlUp
>>
>   If Sheet4.Range("A" & I).Value <> Me.TextBox1.Text Then '転記させた行は削除しているようなので
>      Exit Do                       'Iは同じ数字で比較する
>    End If                          '異なる場合ループを抜ける
>  Loop
>
>>End Sub
>> ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄

【61878】Re:EXCEL VBA 繰返しと計算結果。
発言  にぃ  - 09/6/10(水) 10:37 -

引用なし
パスワード
   ▼おねがいします。 さん:
こんにちは!

>Do を↓で上手くいきました。ありがとうございました。
すみません、最初のDoの位置ですと「NewRow = NewRow + 1」
を入れるのを忘れていたため動作しませんでしたね^^;

>勉強しながらと言うか、ツギハギで作り込んでるので自身が無いんですが
>おかしい(変)所があれば指摘も御願いします。
私もそれほど言える立場ではないのですが、少し言わせていただければ、
RangeやCellsがたくさんありますが、どちらかに統一したほうがいいと思います。
自分だけが見ていればあまり問題ないですが、他の人がみたり、編集したり、
またこのような掲示板で載せる場合にも統一していたほうが見やすく
分析しやすいです。

あとは転機の際にしっかりと「Sheet3」や「Sheet4」を宣言しているので
いちいちSheetをActiveにする必要はないです。


一応下記に少し改善して作ってみましたが、もっといい方法はたくさん
あると思います。参考程度に使ってやってください。

ちなみに比較の際にVariantで置き換えて操作したほうが処理が速くなるので
使用しました。
Variantはとてもいい機能なので機会があったら調べてみてください。

また、動作テストは行ってませんので、テスト環境でこちらは行ってください。
コード的には短くなってないかもしれませんが、処理スピードは速くなっているはずです。


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
  
  Set Ws3 = Sheet3
  Set Ws4 = Sheet4
  
  If (Me.TextBox1.Text = "") Then
    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
    Exit Sub
  End If
  
  With Ws3
    LastRow3 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet3のA列の最後の行の値
    v3 = .Range("A1:A" & LastRow3).Value 'バリアントに代入
      
    For I = 3 To LastRow3
      If Trim(v3(I, 1)) = "" Then '空白行がある場合
        I = NewRow
        Exit For
      End If
    Next
    
    If I > LastRow3 Then ''lastrow3を超えてしまったら
      MsgBox "入力シートに設定できる行がありません。", vbAbortRetryIgnore, "空白行検索"
      Exit Sub
    End If
  End With
  
  With Ws4
    LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet4のA列の最後の行の値
    v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
    
    For I = 2 To LastRow4
      If Me.TextBox1.Text = v4(I, 1) Then '同じ日がある場合、転記操作を行う
        '*******************************************************************************
        '転記操作
        Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
        Sheet3.Range("B" & NewRow).Resize(, 9).Value = .Range("C" & I).Resize(, 9).Value
        Sheet3.Range("K" & NewRow).Value = .Range("AC" & I).Value
        Sheet3.Range("M" & NewRow).Value = .Range("X" & I).Value
        Sheet3.Range("N" & NewRow).Value = Application.RoundDown _
          (Application.WorksheetFunction.Sum(.Range("X" & I).Value / 21 * 35) / 1, 0)
        Sheet3.Range("O" & NewRow).Resize(, 2).Value = .Range("Y" & I).Value
        Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
        Sheet3.Range("R" & NewRow).Value = Application.RoundDown _
          (Application.WorksheetFunction.Sum(.Range("Z" & I).Value / 4 * 7) / 1, 0)
        Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
        Sheet3.Range("W" & NewRow).Resize(, 2).Value = .Range("AD" & I).Resize(, 2).Value
        Sheet3.Range("L" & NewRow).Value = Sheet3.Range("N" & NewRow).Value + _
                          Sheet3.Range("P" & NewRow).Value + _
                          Sheet3.Range("R" & NewRow).Value + _
                          Sheet3.Range("T" & NewRow).Value + _
                          Sheet3.Range("V" & NewRow).Value
        NewRow = NewRow + 1 '次の代入行へ
        delRows = delRows + 1 '削除する回数分の行数を取得
        '*******************************************************************************
        If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
          delRowEnd = I '終わりの行を取得
          Exit For
        End If
      End If
    Next
    
    If I > LastRow4 Then 'lastrow4を超えてしまったら
      MsgBox "入力された*****日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "*****日エラー"
      Exit Sub
    End If
    
    If delRows <> 0 Then
      delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
      .Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
    End If
  
  End With
  
  Set Ws3 = Nothing
  Set Ws4 = Nothing
  
End Sub

【61888】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/10(水) 15:55 -

引用なし
パスワード
   ▼にぃ 様

こんにちは。

気付くのが遅くなってしまい申し訳ありません。
重ね重ねありがとうございます。早速、書き換えてみます。

>
>>Do を↓で上手くいきました。ありがとうございました。
>すみません、最初のDoの位置ですと「NewRow = NewRow + 1」
>を入れるのを忘れていたため動作しませんでしたね^^;
>
>>勉強しながらと言うか、ツギハギで作り込んでるので自身が無いんですが
>>おかしい(変)所があれば指摘も御願いします。
>私もそれほど言える立場ではないのですが、少し言わせていただければ、
>RangeやCellsがたくさんありますが、どちらかに統一したほうがいいと思います。
>自分だけが見ていればあまり問題ないですが、他の人がみたり、編集したり、
>またこのような掲示板で載せる場合にも統一していたほうが見やすく
>分析しやすいです。

そうなんです。自分でも気になっている所なんですが、ツギハギで作ってるのが
出ている部分ですね。

>
>あとは転機の際にしっかりと「Sheet3」や「Sheet4」を宣言しているので
>いちいちSheetをActiveにする必要はないです。

ここも↑と同じと言えば同じなんですが、書きながら自分にも言い聞かせてる部分
でもあり。。;;です。

>
>一応下記に少し改善して作ってみましたが、もっといい方法はたくさん
>あると思います。参考程度に使ってやってください。
>
>ちなみに比較の際にVariantで置き換えて操作したほうが処理が速くなるので
>使用しました。
>Variantはとてもいい機能なので機会があったら調べてみてください。

ありがとうございます。早速、調べてみます。知らない事の方が多いと何から
調べて良いかも分からなくなりがちですが指摘して頂けると、新たな方向性が
見えてきて、幅が広がります。感謝です。

>
>また、動作テストは行ってませんので、テスト環境でこちらは行ってください。
>コード的には短くなってないかもしれませんが、処理スピードは速くなっているはずです。
>

早速、試してみたいと思います。本当にありがとうございました。

【61898】Re:EXCEL VBA 繰返しと計算結果。
質問  おねがいします。  - 09/6/11(木) 11:39 -

引用なし
パスワード
   ▼にぃ 様

こんにちは。お世話になってます。
先日はありがとうございました。

先日から早速試しているんですが、躓いてます。助けてください。

>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
>  
>  Set Ws3 = Sheet3
>  Set Ws4 = Sheet4
>  
>  If (Me.TextBox1.Text = "") Then
>    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
>    Exit Sub
>  End If
>  
>  With Ws3
>    LastRow3 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet3のA列の最後の行の値
>    v3 = .Range("A1:A" & LastRow3).Value 'バリアントに代入
>      
>    For I = 3 To LastRow3
>      If Trim(v3(I, 1)) = "" Then '空白行がある場合
>        I = NewRow
>        Exit For
>      End If
>    Next

  代入のところで値が違います。と出てきます。If Trim(v3(I, 1))
  そこで、LastRow3 = .Range & v3 = .Range の前に Ws3.Range としてみたり
  ↓不等号を < に変えてみたり色々と試してみたんですが、
  ["入力シートに設定できる行がありません。"]または、転記操作の
  Sheet3.Range("A" & NewRow) で [NewRow=0] となります。

  試練を与えて頂いたと思い色々と調べてみたんですが、分かりませんでした。

  申し訳ありませんが、引き続きお願い出来ないでしょうか?
  宜しくお願いします。

>    
>    If I > LastRow3 Then ''lastrow3を超えてしまったら
>      MsgBox "入力シートに設定できる行がありません。", vbAbortRetryIgnore, "空白行検索"
>      Exit Sub
>    End If
>  End With
>  
>  With Ws4
>    LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet4のA列の最後の行の値
>    v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
>    
>    For I = 2 To LastRow4
>      If Me.TextBox1.Text = v4(I, 1) Then '同じ日がある場合、転記操作を行う
>        '*******************************************************************************
>        '転記操作
>        Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
>        Sheet3.Range("B" & NewRow).Resize(, 9).Value = .Range("C" & I).Resize(, 9).Value
>        Sheet3.Range("K" & NewRow).Value = .Range("AC" & I).Value
>        Sheet3.Range("M" & NewRow).Value = .Range("X" & I).Value
>        Sheet3.Range("N" & NewRow).Value = Application.RoundDown _
>          (Application.WorksheetFunction.Sum(.Range("X" & I).Value / 21 * 35) / 1, 0)
>        Sheet3.Range("O" & NewRow).Resize(, 2).Value = .Range("Y" & I).Value
>        Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
>        Sheet3.Range("R" & NewRow).Value = Application.RoundDown _
>          (Application.WorksheetFunction.Sum(.Range("Z" & I).Value / 4 * 7) / 1, 0)
>        Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
>        Sheet3.Range("W" & NewRow).Resize(, 2).Value = .Range("AD" & I).Resize(, 2).Value
>        Sheet3.Range("L" & NewRow).Value = Sheet3.Range("N" & NewRow).Value + _
>                          Sheet3.Range("P" & NewRow).Value + _
>                          Sheet3.Range("R" & NewRow).Value + _
>                          Sheet3.Range("T" & NewRow).Value + _
>                          Sheet3.Range("V" & NewRow).Value
>        NewRow = NewRow + 1 '次の代入行へ
>        delRows = delRows + 1 '削除する回数分の行数を取得
>        '*******************************************************************************
>        If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
>          delRowEnd = I '終わりの行を取得
>          Exit For
>        End If
>      End If
>    Next
>    
>    If I > LastRow4 Then 'lastrow4を超えてしまったら
>      MsgBox "入力された*****日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "*****日エラー"
>      Exit Sub
>    End If
>    
>    If delRows <> 0 Then
>      delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
>      .Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
>    End If
>  
>  End With
>  
>  Set Ws3 = Nothing
>  Set Ws4 = Nothing
>  
>End Sub

【61899】Re:EXCEL VBA 繰返しと計算結果。
発言  neptune  - 09/6/11(木) 14:08 -

引用なし
パスワード
   ▼おねがいします。 さん:
にぃさんではありませんが。。。横から失礼。

>  代入のところで値が違います。と出てきます。If Trim(v3(I, 1))
ソースってのは代入だらけなんですけど。。。。どの部分ですか?
キチンと情報を伝えて見ませんか?第三者が読んでも理解できるように。

>  試練を与えて頂いたと思い色々と調べてみたんですが、分かりませんでした。
こういう所では、UPしてくれるコードは一部の人を除いて、大概サンプルソース
ですから、そういう問題ではないのでは?

サンプル自体は動作確認はしていると思いますから、
・・・キチンとご自分の情報を伝えてないので、
にぃさんもサンプルソース上で対応してないだけと予想します。

そのエラーが発生する前に、ブレークポイントを置き、その時点での
各変数のデータをローカルウィンドウで観察すれば解決できると思います。
「作成したマクロの動作の確認方法」
ht tp://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html

【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

【61902】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/11(木) 16:16 -

引用なし
パスワード
   neptune さん:

こんにちは。

>にぃさんではありませんが。。。横から失礼。

ありがとうございます。

>
>>  代入のところで値が違います。と出てきます。If Trim(v3(I, 1))
>ソースってのは代入だらけなんですけど。。。。どの部分ですか?
>キチンと情報を伝えて見ませんか?第三者が読んでも理解できるように。

そうですね。一応[If Trim(v3(I, 1))]付けておいたんですが、
言葉が足りませんでした。

>
>>  試練を与えて頂いたと思い色々と調べてみたんですが、分かりませんでした。
>こういう所では、UPしてくれるコードは一部の人を除いて、大概サンプルソース
>ですから、そういう問題ではないのでは?

それは、にぃ様とのやり取りの中でこう言う表現になってしまいました。

>
>サンプル自体は動作確認はしていると思いますから、
>・・・キチンとご自分の情報を伝えてないので、
>にぃさんもサンプルソース上で対応してないだけと予想します。
>
>そのエラーが発生する前に、ブレークポイントを置き、その時点での
>各変数のデータをローカルウィンドウで観察すれば解決できると思います。
>「作成したマクロの動作の確認方法」
>ht tp://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html

「作成したマクロの動作の確認方法」←こんなサイトがある事も知りませんでした。
ありがとうございます。早速確認してみます。

【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

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

【61904】Re:EXCEL VBA 繰返しと計算結果。
発言  neptune  - 09/6/11(木) 17:35 -

引用なし
パスワード
   ▼おねがいします。 さん:
こんにちは

アドバイスもせずに突込みっぽい書き込みばかりでごめんなさいね。

>そうですね。一応[If Trim(v3(I, 1))]付けておいたんですが、
>言葉が足りませんでした。

一応今後の質問する時のために嫌とは思いますが、指摘しておきます。

>[If Trim(v3(I, 1))]
は代入とは言いません。
if trim(v3(i,1))="条件"
と書いていてもそれは同じです。代入ではありません。↑はif文における評価式
で意味が全く違います。

trim(v3(i,1))="条件"
が代入式です。(ifステートメントではない)

if文による条件の評価、又は条件式とでも言えば通じました。
大概、ある程度は違う用語でもタイプミスとか、かする程度の意味なら
判るんですが
私は特に頭が固いせいか記述も、用語も違うと、想像したり、考えるのが
面倒になってしまいます。

まぁこんな人もいるので、なるべく用語は正しくお使いになった方が
多くの人からアドバイスを頂ける可能性も増えると思います。

【61905】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/11(木) 18:34 -

引用なし
パスワード
   ▼neptune さん

こんにちは

>
>アドバイスもせずに突込みっぽい書き込みばかりでごめんなさいね。
>
>>そうですね。一応[If Trim(v3(I, 1))]付けておいたんですが、
>>言葉が足りませんでした。
>
>一応今後の質問する時のために嫌とは思いますが、指摘しておきます。
>
>>[If Trim(v3(I, 1))]
>は代入とは言いません。
>if trim(v3(i,1))="条件"
>と書いていてもそれは同じです。代入ではありません。↑はif文における評価式
>で意味が全く違います。

そうなんです。やっぱり言葉が足りませんね。

    v3 = .Range("A1:A" & LastRow3).Value  の代入の型が違うエラーになり

    If Trim(v3(I, 1)) = "" Then  の v3 がエラーで

空白行が無いと帰ってきていました。

>
>trim(v3(i,1))="条件"
>が代入式です。(ifステートメントではない)
>
>if文による条件の評価、又は条件式とでも言えば通じました。
>大概、ある程度は違う用語でもタイプミスとか、かする程度の意味なら
>判るんですが
>私は特に頭が固いせいか記述も、用語も違うと、想像したり、考えるのが
>面倒になってしまいます。
>
>まぁこんな人もいるので、なるべく用語は正しくお使いになった方が
>多くの人からアドバイスを頂ける可能性も増えると思います。

そうですね。ご指摘ありがとうございます。

【61912】Re:EXCEL VBA 繰返しと計算結果。
発言  neptune  - 09/6/11(木) 22:18 -

引用なし
パスワード
   ▼おねがいします。 さん:
こんにちは

これなら良く判ります。
>    v3 = .Range("A1:A" & LastRow3).Value  の代入の型が違うエラーになり
矢印の文自体はLastRow3が0でない限りエラーにはならんと思います。

・ブレークポイントを↑の式におき
・LastRow3のデータをローカルウィンドウで確認する
・正常であれば、1行実行して、v3のデータをローカルウィンドウで確認する
のようなやり方でデバッグするのが良いかと思います。
(データを見れば何が悪いか判るはず。)

>
>    If Trim(v3(I, 1)) = "" Then  の v3 がエラーで
v3にデータが正常に入ってない場合はエラーになるでしょう。

#1個前の書き込みで逆切れされなくて良かった。^ ^
#自分に嫌な事書かれると切れる人は珍しくないのでねぇ。。
#ボチボチでも進歩して頑張って下さいね。

【61919】Re:EXCEL VBA 繰返しと計算結果。
発言  Hirofumi  - 09/6/12(金) 8:46 -

引用なし
パスワード
   簡単なテストデータを作って試した所、幾つか気に成る所が出て来たのでレスします

1、Sheet4のA列に日付がシリアル値で入って居るか否か?
 シリアル値の場合、私のコードもにぃさんのコードも日付の抽出は出来ないようです
 因って、細工が必要と思われます
2、私のコードの場合、Sheet3に対しての出力を配列変数を使って行って居ますので
 Sheet3のA〜X列に算式が設定されている場合、これを消してしまいますので
 コードの変更が必要に成ります

にぃさんのコードに就いて名のですが

1、前回のレスに書いた「 i = NewRow」は「NewRow = i」の間違いの様です
2、Sheet4のListは、日付列(A列)で整列されている事が条件の様です
3、出力されるSheet3では、A列が既に埋まって居て、そのA3〜最終行までの間で
 空行をを探しその位置から転記を始める様に成って居ますので
 A3以降のセルにに何も入って居ない場合、"入力シートに設定できる行がありません。"が
 でて終了してしまいます
 Testするなら、例えばA200ぐらいに位置に例えば「ListEnd」とでも入れて試して見たら善いと思います

【61922】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/12(金) 10:14 -

引用なし
パスワード
   ▼neptune さん:

こんにちは

>
>これなら良く判ります。
>>    v3 = .Range("A1:A" & LastRow3).Value  の代入の型が違うエラーになり
>矢印の文自体はLastRow3が0でない限りエラーにはならんと思います。
>
>・ブレークポイントを↑の式におき
>・LastRow3のデータをローカルウィンドウで確認する
>・正常であれば、1行実行して、v3のデータをローカルウィンドウで確認する
>のようなやり方でデバッグするのが良いかと思います。
>(データを見れば何が悪いか判るはず。)
>
>>
>>    If Trim(v3(I, 1)) = "" Then  の v3 がエラーで
>v3にデータが正常に入ってない場合はエラーになるでしょう。
>
>#1個前の書き込みで逆切れされなくて良かった。^ ^
>#自分に嫌な事書かれると切れる人は珍しくないのでねぇ。。
>#ボチボチでも進歩して頑張って下さいね。

ありがとうございます。なかなか難しいです。
今までのやり方を変えたい!?もっと良い違った方法があるんじゃ?
と思い調べ始めても、独学に限界が。と言うか自分で限界を作って
いるんでしょうね。理解も浅いため漠然とした質問しか出来ていな
いのも問題なんだと思っています。

にぃ さん や、Hirofumi さん に書いて頂いたコードをコンパイル
チェックしながら一行ずつ内容を確認しています。

少し時間が掛ると思いますが、皆さんからヒントを沢山頂いたので
なんとか完成させたいと思っています。

結果はこちらでご報告させて頂くつもりです。
ありがとうございました。

途中、質問させて頂く事もあると思いますが、宜しくお願いします。

【61924】Re:EXCEL VBA 繰返しと計算結果。
発言  neptune  - 09/6/12(金) 10:34 -

引用なし
パスワード
   ▼おねがいします。 さん:

こんにちは
>ありがとうございます。なかなか難しいです。
最初はみんな訳がわかりません。だから、私も参考書で勉強しましたね。
やはり基本的な内容に於いてはWebより参考書の方が為になりました。

>今までのやり方を変えたい!?もっと良い違った方法があるんじゃ?
>と思い調べ始めても、独学に限界が。と言うか自分で限界を作って
>いるんでしょうね。理解も浅いため漠然とした質問しか出来ていな
>いのも問題なんだと思っています。
私もそうですが、此方で回答のレスをつけておられる方の殆どは独学
でしょうし、プロでもないと思いますよ。

限界の話ですが、心配しなくてもも〜と高い所にあります。^ ^;;
限界に気付くと今度は、他言語や、
本物のVB(VB2008 Express Editionなど無償のものもあります。)
に手を出したくなるかもしれません。。。

もう少し頑張れば、調べるスキル(これがなかなか難しい)も付いて
進歩が早くなるでしょう。

頑張って下さい。

【61925】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/12(金) 10:49 -

引用なし
パスワード
   ▼Hirofumi さん:

こんにちは。
ありがとうございます。

>簡単なテストデータを作って試した所、幾つか気に成る所が出て来たのでレスします
>
>1、Sheet4のA列に日付がシリアル値で入って居るか否か?
> シリアル値の場合、私のコードもにぃさんのコードも日付の抽出は出来ないようです
> 因って、細工が必要と思われます

シリアル値ではなく、8桁の数値です。 20090424

>2、私のコードの場合、Sheet3に対しての出力を配列変数を使って行って居ますので
> Sheet3のA〜X列に算式が設定されている場合、これを消してしまいますので
> コードの変更が必要に成ります

Sheet3のA〜X列 の列見出し(文字列)以降のセルは空白です。
以降は月次で転記(設定)されていく値のみになります。

>
>にぃさんのコードに就いて名のですが
>
>1、前回のレスに書いた「 i = NewRow」は「NewRow = i」の間違いの様です
>2、Sheet4のListは、日付列(A列)で整列されている事が条件の様です
>3、出力されるSheet3では、A列が既に埋まって居て、そのA3〜最終行までの間で
> 空行をを探しその位置から転記を始める様に成って居ますので
> A3以降のセルにに何も入って居ない場合、"入力シートに設定できる行がありません。"が
> でて終了してしまいます
> Testするなら、例えばA200ぐらいに位置に例えば「ListEnd」とでも入れて試して見たら善いと思います

ありがとうございます。早速試してみます。

先日も、NewRow = i で試したりしてみたんですが、状況が変わらず、
NewRow = i のところを、LastRow3 = LastRow3 とか + 1 にしてみたり

    LastRow3 = .Range("A" & .Rows.Count).End(xlUp).Row
                     ↓
    LastRow3 = Ws3.Range("A" & Ws3.Rows.Count).End(xlUp).Row  の様に

他の行にも全てに追記し、

        '転記操作
        Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
                     ↓
        Sheet3.Range("A" & LastRow3).Value = .Range("A" & I).Value

に変更してみたり。

結果としては、転記(設定)出来たんですが、Sheet4 はそのまま残ってました。と言うか
転記終了後の↓の部分でエラーで止まってしまいました。

    If Me.TextBox1.Text <> v4(I + 1, 1) Then

にぃ さん と Hirofumi さん に書いて頂いたコードを無駄にしない様になんとか
完成させたいと思っています。
途中、また質問させて頂く事もあると思いますが、宜しくお願いします。
また、お気付きの点がありましたら、宜しくお願い致します。

【61934】Re:EXCEL VBA 繰返しと計算結果。
質問  おねがいします。  - 09/6/12(金) 17:34 -

引用なし
パスワード
   ▼にぃ さん:
▼Hirofumi さん:
▼neptune さん:

こんにちは。お世話になります。
下記のような変更+してみました。最後のところでエラーが出てしまいます。
申し訳ありまあせんが、宜しくお願いします。

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
 
  Set Ws3 = Sheet3
  Set Ws4 = Sheet4
 
  If (Me.TextBox1.Text = "") Then
    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
    Exit Sub
  End If
 
  With Ws3
    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
>====【ここまで】==============
 
  With Ws4
    LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet4のA列の最後の行の値
    v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
  
    For I = 2 To LastRow4
      If Me.TextBox1.Text = v4(I, 1) Then '同じ日がある場合、転記操作を行う
      
  '***転記*********************************************************************************************
  Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
  Sheet3.Range("B" & NewRow).Resize(, 9).Value = .Range("C" & I).Resize(, 9).Value
  Sheet3.Range("K" & NewRow).Value = .Range("AC" & I).Value
  Sheet3.Range("M" & NewRow).Value = .Range("X" & I).Value
  Sheet3.Range("N" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                    (.Range("X" & I).Value / TextBox2.Text * TextBox3.Text) / 1, 0)
  Sheet3.Range("O" & NewRow).Value = .Range("Y" & I).Value
  Sheet3.Range("P" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                    (.Range("Y" & I).Value / TextBox4.Text * TextBox5.Text) / 1, 0)
  Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
  Sheet3.Range("R" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                    (.Range("Z" & I).Value / TextBox6.Text * TextBox7.Text) / 1, 0)
  Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
  Sheet3.Range("T" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                    (.Range("AA" & I).Value / TextBox8.Text * TextBox9.Text) / 1, 0)
  Sheet3.Range("U" & NewRow).Resize(, 2).Value = .Range("AD" & I).Resize(, 2).Value
  Sheet3.Range("L" & NewRow).Value = Sheet3.Range("N" & NewRow).Value + _
  Sheet3.Range("P" & NewRow).Value + Sheet3.Range("R" & NewRow).Value + Sheet3.Range("T" & NewRow).Value
  
  NewRow = NewRow + 1        '次の代入行へ
  delRows = delRows + 1     '削除する回数分の行数を取得
  '****************************************************************************************************

>ここで◆エラーになります。
>                   ◆↓v4(I + 1, 1)<インデックスが有効な範囲にありません>
>=========◆→  If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
          delRowEnd = I '終わりの行を取得
          Exit For
        End If
      End If
    Next
  
    If I > LastRow4 Then 'lastrow4を超えてしまったら
      MsgBox "入力された支給日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "支給日エラー"
      Exit Sub
    End If
  
    If delRows <> 0 Then
      delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
      .Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
    End If
 
  End With
 
  Set Ws3 = Nothing
  Set Ws4 = Nothing
 
End Sub

>試行錯誤しながら、コンパイルチェックしてみてるんですが先に進めません。
>転記までの部分は上手く動いてくれています。が、roopflg のところで何か不都合が
>ありましたらご指摘お願いします。

【61935】Re:EXCEL VBA 繰返しと計算結果。
回答  neptune  - 09/6/12(金) 22:21 -

引用なし
パスワード
   ▼おねがいします。 さん:
見にくかったので、少しだけ見易くしました。全体としては変更してません。
問題部分だけしか見てないし、検証もしておりませんので
検証願います。もし動いたら無駄変数の確認もしてください。

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

  Set Ws4 = Sheet4

  If ChkData = False Then Exit Sub

  With Ws4
    LastRow4 = .Range("A" & .Rows.Count).End(xlUp).Row 'sheet4のA列の最後の行の値
    v4 = .Range("A1:A" & LastRow4).Value 'バリアントに代入
 
    For I = 2 To LastRow4
      If Me.TextBox1.Text = v4(I, 1) Then '同じ日がある場合、転記操作を行う
         '***転記*********************************************************************************************
         Sheet3.Range("A" & NewRow).Value = .Range("A" & I).Value
         Sheet3.Range("B" & NewRow).Resize(, 9).Value = .Range("C" & I).Resize(, 9).Value
         Sheet3.Range("K" & NewRow).Value = .Range("AC" & I).Value
         Sheet3.Range("M" & NewRow).Value = .Range("X" & I).Value
         Sheet3.Range("N" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                           (.Range("X" & I).Value / TextBox2.Text * TextBox3.Text) / 1, 0)
         Sheet3.Range("O" & NewRow).Value = .Range("Y" & I).Value
         Sheet3.Range("P" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                           (.Range("Y" & I).Value / TextBox4.Text * TextBox5.Text) / 1, 0)
         Sheet3.Range("Q" & NewRow).Value = .Range("Z" & I).Value
         Sheet3.Range("R" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                           (.Range("Z" & I).Value / TextBox6.Text * TextBox7.Text) / 1, 0)
         Sheet3.Range("S" & NewRow).Resize(, 2).Value = .Range("AA" & I).Value
         Sheet3.Range("T" & NewRow).Value = Application.RoundDown(Application.WorksheetFunction.Sum _
                           (.Range("AA" & I).Value / TextBox8.Text * TextBox9.Text) / 1, 0)
         Sheet3.Range("U" & NewRow).Resize(, 2).Value = .Range("AD" & I).Resize(, 2).Value
         Sheet3.Range("L" & NewRow).Value = Sheet3.Range("N" & NewRow).Value + _
         Sheet3.Range("P" & NewRow).Value + Sheet3.Range("R" & NewRow).Value + Sheet3.Range("T" & NewRow).Value
        
         NewRow = NewRow + 1        '次の代入行へ
         delRows = delRows + 1     '削除する回数分の行数を取得
         '****************************************************************************************************

'        ◆↓v4(I + 1, 1)<インデックスが有効な範囲にありません>
        If I + 1 <= LastRow4 Then  'インデックスが有効な範囲である事を確認
          If Me.TextBox1.Text <> v4(I + 1, 1) Then '次の行が異なればループを抜ける
            delRowEnd = I '終わりの行を取得
            Exit For
          End If
        End If
      End If
    Next
 
    If I > LastRow4 Then 'lastrow4を超えてしまったら
      MsgBox "入力された支給日は存在しませんでした。確認してください。", vbAbortRetryIgnore, "支給日エラー"
      Exit Sub
    End If
 
    If delRows <> 0 Then
      delRowStart = delRowEnd - delRows + 1 '削除する最初の行を取得
      .Rows(delRowStart & ":" & delRowEnd).Delete Shift:=xlUp
    End If

  End With

  Set Ws4 = Nothing

End Sub


Private Function ChkData() As Boolean
  Const sWorkSheetName As String = "Sheet3"
  Dim Ws3 As Worksheet
  Dim LastRow3 As Long, NewRow As Long
  Dim roopflg As Boolean
  
  Set Ws3 = Worksheets(sWorkSheetName)
  
  If (Me.TextBox1.Text = "") Then
    MsgBox "*****日を入力してください。", vbInformation, "入力エラー"
    ChkData = False
    Exit Function
  End If

  With Ws3
    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, "空白行検索"
      ChkData = False
      Exit Function
    End If
 
  End With
'>====【ここまで】==============
  ChkData = True
End Function

【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

【61938】Re:EXCEL VBA 繰返しと計算結果。
回答  Hirofumi  - 09/6/13(土) 8:59 -

引用なし
パスワード
   Upしてから気が付きました

        '★Sheet4の整列をさせない為削除

と書いてのですが、これは、

        '★Sheet4の整列をしなくても善い様にする為、為削除

です、修正コードでは、Loop内で削除処理も行う為、日付が整列している必要は無くなります
また、

'★行削除の為、代入式右辺の「i」を「i + delRows」に変更

と書きましたが、此れは

'★行削除の為、代入式右辺の「i」を「i - delRows」に変更

の間違いです
後もう一点、今回TextBox2〜9が追加されている様ですが
このTextBoxの値が「0」の場合0の乗算が行われエラーに成ります
また、TextBoxの値が空白("")もしくは、文字列の場合、型違いのエラーが発生しますので
TextBox2〜9の値のチェックをコードの先頭で入れるべきと思います



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

  '★TextBox2〜9のチェック
  For i = 2 To 9
    If Val(Me.Controls("TextBox" & i)) = 0 Then
      strPrompt = "TextBox" & i & "の値が不正です確認して下さい"
      GoTo Wayout
    End If
  Next i

【61963】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/15(月) 10:19 -

引用なし
パスワード
   ▼Hirofumi さん:

こんにちは。お世話になってます。
いつもありがとうございます。

早速、最初の修正
> v4 = .Range("A1:A" & (LastRow4 + 1)).Value 'バリアントに代入
からテストしてみました。問題無く処理が完了出来ました。

少し時間が掛かってしまうかも知れませんが、以降の修正点をこれから
テストしていきます。
これまでご指摘頂けた部分を自分のモノに出来る様にやってみます。

途中、また質問させて頂く事もあると思いますが、宜しくお願いします。
また、お気付きの点がありましたら、宜しくお願い致します。

【61968】Re:EXCEL VBA 繰返しと計算結果。
お礼  おねがいします。  - 09/6/15(月) 15:03 -

引用なし
パスワード
   ▼neptune さん:

ありがとうございます。

検証していますが、なかなか難しいです。

求める結果は同じでも色々な方法が有るんですね。
にぃ さん。neptune さん。Hirofumi さん。に書いて頂いた内容を
自分なりに噛み砕いて勉強(調べて)しています。

もう少し時間が掛りそうですが、ご報告致します。

宜しくお願いします。

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