[[20210608115548]]　『セルの計算を簡略化』（やす）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『セルの計算を簡略化』（やす）

別シートから条件付きで持ってきたデータをボタンで一発編集するために以下のVBAをまとめてコールしています。

Option Private Module

Sub 未納額計算() 

    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "R") = Cells(i, "AB") - Cells(i, "S")
    Next
End Sub

*****************************************************

Sub 当月金額計算() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "S") = Cells(i, "T")
    Next
End Sub

*****************************************************

Sub 翌月金額計算() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "T") = Cells(i, "U")
    Next
End Sub

*****************************************************

Sub 翌々月金額クリア() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Range("U6", "U" & n).ClearContents
    Next

End Sub

*****************************************************

Sub 未納個数計算() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "V") = Cells(i, "AF") - Cells(i, "W")
    Next
End Sub

*****************************************************

Sub 当月個数計算() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "W") = Cells(i, "X")
    Next
End Sub

*****************************************************

Sub 翌月個数計算() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Cells(i, "X") = Cells(i, "Y")
    Next
End Sub

*****************************************************

Sub 翌々月個数クリア() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Range("Y6", "Y" & n).ClearContents
    Next
End Sub

*****************************************************

Sub ABからAFクリア() 
    Dim n
    Dim i


    n = Cells(Rows.Count, "AB").End(xlUp).Row
    For i = 6 To n
        Range("AB6", "AI" & n).ClearContents
    Next
End Sub

*****************************************************

これらをまとめて軽くしたいのです。
宜しくお願いします。

簡単に説明すると

6行目からAB列の最下行まで同行での変更
〇単純に移動
S,TにAD,AE
W,XにAH,AI

〇差を求める
RにAB-AC
VにAF-AG

〇コンテンツ削除
ABからAIを削除

宜しくお願いします。

＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞

マクロと説明に齟齬がありますがひとまず説明に従います 

 Sub Sample()
    Dim var() As Variant
    Dim rng As Range
    Dim cnt As Long
    Dim i As Long, j As Long
    Set rng = Range(Cells(6, "AB"), Cells(Rows.Count, "AB").End(xlUp)).Resize(, 4)
    For j = 0 To 1
        Set rng = rng.Offset(, j * 4)
        ReDim var(1 To rng.Rows.Count, 1 To 3)
        For i = LBound(var, 1) To UBound(var, 1)
            var(i, 1) = rng(i, 1) - rng(i, 2)
            var(i, 2) = rng(i, 3)
            var(i, 3) = rng(i, 4)
        Next
        Range("R6").Resize(UBound(var, 1), UBound(var, 2)).Offset(, j * 4) = var
        rng.ClearContents
    Next
 End Sub

（毒電波塔） 2021/06/08(火) 13:35

毒電波塔さん

あら、確かにマクロ違いましたね。
前回まで使用していて、引用先セル変わっていたの忘れていました。

こちらで稼働しました！！
ありがとうございました！！
（やす） 2021/06/08(火) 14:27

[[20210607172300]]　『このVBAをもっと軽くできますか？？』（やす）
↑でループをする必要はないことを説明しましたし

[[20210603152142]]　『受注残が０以外を別シートに転記』（みっち）
↑で値を減算貼付すればよいとコメントしたので、

それぞれが理解できれば↓みたいにすればよいと思いつきそうですが検討しなかったのですか？ 

    Sub まとめ()
        Dim n As Long, i As Long


        With ActiveSheet
            n = .Cells(.Rows.Count, "AB").End(xlUp).Row


            If n < 6 Then Exit Sub


            For i = 0 To 4 Step 4


                .Range("S6:T" & n).Offset(, i).Value = .Range("AD6:AE" & n).Offset(, i).Value


                With .Range("R6:R" & n).Offset(, i)
                    .Value = .Parent.Range("AB6").Offset(, i).Resize(.Rows.Count).Value
                    Intersect(.EntireRow, .Parent.Columns("AC").Offset(, i)).Copy
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
                End With
            Next i


        End With
    End Sub

（もこな２） 2021/06/08(火) 18:29

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.