Excel VBA質問箱 IV

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

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


20276 / 76732 ←次へ | 前へ→

【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

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 お礼

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