Excel VBA質問箱 IV

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

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


11013 / 13644 ツリー ←次へ | 前へ→

【18651】最終行データを先頭行へコピーペーストは? EBI 04/10/3(日) 9:12 質問[未読]
【18654】Re:最終行データを先頭行へコピーペースト... [名前なし] 04/10/3(日) 10:21 回答[未読]
【18655】Re:最終行データを先頭行へコピーペース... EBI 04/10/3(日) 15:11 質問[未読]
【18657】Re:最終行データを先頭行へコピーペース... Hirofumi 04/10/3(日) 16:38 回答[未読]
【18662】Re:最終行データを先頭行へコピーペース... EBI 04/10/3(日) 21:30 お礼[未読]

【18651】最終行データを先頭行へコピーペーストは...
質問  EBI E-MAIL  - 04/10/3(日) 9:12 -

引用なし
パスワード
   入力されているデータの値だけをクリアするマクロがあります。(以下はそのコードです)
このクリアする時に、最終行の値を最初の行へコピーペーストしたいと考えています。
これをマクロの中で行うにはどうすればいいでしょうか。
(以下の例では6行目のデータを4行目へコピーする)
表の内容は”預金通帳”の様なものとみて頂ければ結構です。
「出」「入」は数値だけ。「残高」はその出入りを計算する数式が入っています。
INDEX関数、MATCH関数で出来ると思うのですが悩んでいます。
よろしくお願いします。


Sub 年度経過削除()
Dim BtNum As Integer
BtNum = MsgBox("年度変更によりデータを削除します。", _
vbOKCancel + vbExclamation, "年度更新")
If BtNum = 2 Then Exit Sub
Dim RR As Long, r1 As Range
  With ActiveSheet
   For RR = 4 To 20
     If .Cells(RR, 2).Value < "cells(2,9)" Then
      On Error Resume Next
      Set r1 = .Rows(RR).SpecialCells(xlCellTypeConstants)
      If Not r1 Is Nothing Then r1.ClearContents
      On Error GoTo 0
      Set r1 = Nothing
     End If
   Next
  End With

End Sub

--------------------------------------------------------------------
2                    =TODAY()
3 日付   出    入    残高
4     2000   5000    200000
5          1000    201000
6      500         200500
7
8

【18654】Re:最終行データを先頭行へコピーペース...
回答  [名前なし]  - 04/10/3(日) 10:21 -

引用なし
パスワード
   ▼EBI さん:
下の部分を追加したら出来ると思います。

>Sub 年度経過削除()
> Dim BtNum As Integer
> BtNum = MsgBox("年度変更によりデータを削除します。", _
> vbOKCancel + vbExclamation, "年度更新")
> If BtNum = 2 Then Exit Sub
> Dim RR As Long, r1 As Range
 Dim LastRow As Long
  LastRow = Cells(21, 2).End(xlUp).Row 'B列の最終行を取得
>  With ActiveSheet
>   For RR = 4 To 20
     If .Cells(RR, 2).Value < .Cells(2, 9).Value Then '←ここ変えました。
>      On Error Resume Next
>      Set r1 = .Rows(RR).SpecialCells(xlCellTypeConstants)
      If RR = LastRow Then
        r1.Copy
        Cells(4, 2).PasteSpecial
        Application.CutCopyMode = False
      End If
>      If Not r1 Is Nothing Then r1.ClearContents
>      On Error GoTo 0
>      Set r1 = Nothing
>     End If
>   Next
>  End With
>
>End Sub

【18655】Re:最終行データを先頭行へコピーペース...
質問  EBI E-MAIL  - 04/10/3(日) 15:11 -

引用なし
パスワード
   ありがとうございます。
半分は出来ました。少し不具合があります。
最終行の一部分しかコピー出来ないのです。
出来たのは日付と「出」「入」だけです。その「出、入」でも「出」が数値なしであった場合には
「入」の数値が「出」にペーストされます。
また、残高は全然ペーストされません。

以下の例で、7行目の10/7は正しく4行目のBへ、3枚3000がC列D列4行目へペーストされます。残高35枚、174000がペーストされません。

H行の数式です。G行も同様。ただし、G4とH4は数式無しです。
=IF(H4="","",IF(AND(D5="",F5=""),"",H4-D5+F5))


  B    C   D     E   F    G    H   I
2                               =TODAY()
3 日付  枚数  出   枚数 入   枚数 残高
4 9/9    1  2000   2  5000   33  200000
5 9/30            1  1000   34  201000
6 10/1   2  30000          32  171000
7 10/3            3  3000   35  174000
8

【18657】Re:最終行データを先頭行へコピーペース...
回答  Hirofumi  - 04/10/3(日) 16:38 -

引用なし
パスワード
   此れでどうかな?

Sub 年度経過削除()

  Dim RR As Long, r1 As Range
  Dim lngListEnd As Long
  
  If MsgBox("年度変更によりデータを削除します。", _
      vbOKCancel + vbExclamation, "年度更新") = vbCancel Then
    Exit Sub
  End If
  
  With ActiveSheet
    lngListEnd = .Cells(65536, "B").End(xlUp).Row
    If lngListEnd < 4 Then
      Exit Sub
    End If
    .Cells(4, "B").Resize(, 7).Value _
        = .Cells(lngListEnd, "B").Resize(, 7).Value
'    For RR = 4 To 20
    For RR = 5 To lngListEnd
      If .Cells(RR, 2).Value < .Cells(2, 9).Value Then '★?
        On Error Resume Next
        Set r1 = .Rows(RR).SpecialCells(xlCellTypeConstants)
        If Not r1 Is Nothing Then
          r1.ClearContents
        End If
        On Error GoTo 0
        Set r1 = Nothing
      End If
    Next RR
  End With

End Sub

【18662】Re:最終行データを先頭行へコピーペース...
お礼  EBI E-MAIL  - 04/10/3(日) 21:30 -

引用なし
パスワード
   ありがとうございました。
問題ありません。
思い通りの結果が得られました。
今後もよろしくお願いします。

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