Excelのマクロに関する質問です。良い回答は、200ポイント差し上げます。

ファイルには2つのシートがあり、
期限の過ぎたセル(−10以降)を確認→その行を削除→別シートの最終行にデータを追加

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

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

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2010/12/18 02:47:41
  • 終了:2010/12/20 10:04:27

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692010/12/18 10:46:08

ポイント200pt

コード中に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
id:anim130M

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

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

2010/12/20 10:03:07

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692010/12/18 10:46:08ここでベストアンサー

ポイント200pt

コード中に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
id:anim130M

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

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

2010/12/20 10:03:07
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982010/12/18 06:53:45

ポイント50pt
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シートにある順になるようにしました。

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

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

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

id:anim130M

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

2010/12/20 10:03:14
id:M-i No.3

M-i回答回数55ベストアンサー獲得回数02010/12/19 12:51:55

id:anim130M

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

2010/12/20 10:03:18

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません