人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelのマクロに関する質問です。良い回答は、200ポイント差し上げます。
ファイルには2つのシートがあり、
期限の過ぎたセル(-10以降)を確認→その行を削除→別シートの最終行にデータを追加

【Aシート】
3 機器名 オプション 値
4 テレビ スイッチ 3
5 ビデオ リモコン -5
6 ゲーム ボタン -10 ←行を削除

【Bシート】
3 機器名 部品名 値
4 冷蔵庫 なし -15
5 ゲーム ボタン -10 ←行を追加

どうか宜しくお願いします。


●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:Excel オプション ゲーム スイッチ セル
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●200ポイント ベストアンサー

コード中に1箇所あるAシート、Bシートというところを実際のシート名に変更してください。


Sub Macro()
 Application.ScreenUpdating = False
 
 Dim lastRowA As Long
 Dim lastRowB As Long
 Dim i As Long
 Dim wsA As Worksheet
 Dim wsB As Worksheet
 
 Set wsA = Worksheets("Aシート")
 Set wsB = Worksheets("Bシート")
 
 lastRowA = wsA.Cells(Rows.Count, 1).End(xlUp).Row
 
 For i = 3 To lastRowA
 If wsA.Cells(i, "C").Value <= -10 Then
 lastRowB = wsB.Cells(Rows.Count, 1).End(xlUp).Row
 wsA.Rows(i).Copy wsB.Rows(lastRowB + 1)
 wsA.Rows(i).Delete
 i = i - 1
 lastRowA = lastRowA - 1
 End If
 Next i
 
 Application.ScreenUpdating = True
End Sub

1つ気になったのですが、C列(期限)などのセルが数式で他の行を参照している場合は

そのままコピーすると値が変わってしまうことになります。

その場合値のみをコピーするには次のように変えます。

Sub Macro()
 Application.ScreenUpdating = False
 
 Dim lastRowA As Long
 Dim lastRowB As Long
 Dim i As Long
 Dim wsA As Worksheet
 Dim wsB As Worksheet
 
 Set wsA = Worksheets("Aシート")
 Set wsB = Worksheets("Bシート")
 
 lastRowA = wsA.Cells(Rows.Count, 1).End(xlUp).Row
 
 For i = 3 To lastRowA
 If wsA.Cells(i, "C").Value <= -10 Then
 lastRowB = wsB.Cells(Rows.Count, 1).End(xlUp).Row
 wsA.Rows(i).Copy
 wsB.Rows(lastRowB + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
 Application.CutCopyMode = False
 wsA.Rows(i).Delete
 i = i - 1
 lastRowA = lastRowA - 1
 End If
 Next i
 
 Application.ScreenUpdating = True
End Sub
◎質問者からの返答

回答いただきありがとうございました。

フィットしたので、採用することにしました。


2 ● きゃづみぃ
●50ポイント
Sub 実行()

a = "Aシート"
b = "Bシート"

For b1 = 3 To 65536
 If Worksheets(a).Cells(b1, "A") = "" Then Exit For
 If Worksheets(a).Cells(b1, "C") <= -10 Then
 a1 = Worksheets(b).Cells(65536, "A").End(xlUp).Row + 1
 
 Worksheets(b).Cells(a1, "A") = Worksheets(a).Cells(b1, "A")
 Worksheets(b).Cells(a1, "B") = Worksheets(a).Cells(b1, "B")
 Worksheets(b).Cells(a1, "C") = Worksheets(a).Cells(b1, "C")
 
 Worksheets(a).Cells(b1, "A") = ""
 Worksheets(a).Cells(b1, "B") = ""
 Worksheets(a).Cells(b1, "C") = ""
 
 End If
Next b1

For b1 = Cells(65536, "A").End(xlUp).Row To 3 Step -1
 If Worksheets(a).Cells(b1, "A") = "" Then
 Worksheets(a).Rows(b1).Delete Shift:=xlUp
 End If
Next b1

End Sub

Bシートに追加する時、Aシートにある順になるようにしました。

なので 削除は 別にループさせてやってるのです。

普通は行の削除を行うときは、一番下の行からチェックしていくのですが

そうなると 追加するのが 逆順になっちゃいますからね。

◎質問者からの返答

回答いただきありがとうございました。


3 ● M-i
●5ポイント

http://homepage1.nifty.com/gak/MSTips/excel.html

◎質問者からの返答

回答いただきありがとうございました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ