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

Question

anim130M

31

30もっと見る

255pt

ビジネス・経営コンピュータ

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

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

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

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

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

回答の条件

1人5回まで

登録：2010/12/18 02:47:41
終了：2010/12/20 10:04:27

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.2

きゃづみぃ1353911982010/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シートにある順になるようにしました。

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

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

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

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

2010/12/20 10:03:14

No.3

M-i5502010/12/19 12:51:55

5pt

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

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

2010/12/20 10:03:18

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

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

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

リクエスト送信済

回答リクエストを送信したユーザーはいません

SALINGER · Accepted Answer · 2010-12-18T10:46:08+09:00

コード中に１箇所ある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

１つ気になったのですが、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

SALINGER · Accepted Answer · 2010-12-18T10:46:08+09:00

コード中に１箇所ある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

１つ気になったのですが、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

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

ベストアンサー

SALINGER34549692010/12/18 10:46:08

その他の回答（2件）

SALINGER34549692010/12/18 10:46:08ここでベストアンサー

きゃづみぃ1353911982010/12/18 06:53:45

M-i5502010/12/19 12:51:55

コメント（0件)

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