Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

11015 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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

- 04/10/3(日) 9:12 -


	引用なし

	パスワード

入力されているデータの値だけをクリアするマクロがあります。（以下はそのコードです）
このクリアする時に、最終行の値を最初の行へコピーペーストしたいと考えています。
これをマクロの中で行うにはどうすればいいでしょうか。
（以下の例では６行目のデータを４行目へコピーする）
表の内容は”預金通帳”の様なものとみて頂ければ結構です。
「出」「入」は数値だけ。「残高」はその出入りを計算する数式が入っています。
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

- 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

- 04/10/3(日) 21:30 -


	引用なし

	パスワード

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

11015 / 13646 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free