[[20221103162819]]　『VBAで規則的に足し算したい』（ぽぽ）　ページの最後に飛ぶ

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

　

『VBAで規則的に足し算したい』（ぽぽ）

初めまして。
元データは下記イメージです。
実際は、あいうえおの繰り返しが何百と続きます。列も数字の入っている列が20列位あります。
やりたい事は、あいうえおの5行のセットを3行に減らしたいです。
具体的には、「あ」と「い」は「い」の行に足し算したい。「う」と「お」も同様に、「う」の行に、「う＋お」の値を計算して、5行から3行に減らしたいです。それをマクロでやらせたいのですが…。
行を減らしたあとは、い、う、えが残ります。 

   A    B   C   D   E   F
 1  aa  bb  空  cc  空  dd  
 2  あ  1       4       2   
 3  い  2       1       2   
 4  う  1       2       2
 5  え  1       1       2
 6  お  2       1       2
 7  あ  3       6       2
 8  い  3       6       2
 9  う  1       4       2
 10 え  5       4       2
 11 お  3       4       2

マクロ処理後のイメージ 

   A    B   C   D   E   F
 1  aa  bb  空  cc  空  dd  
 2  い  3       5       4  　'←あ+い 
 3  う  3       3       4  　'←う+お 
 4  え  1       1       2
 5  い  6       12      4  　'←あ+い 
 6  う  4       8       4  　'←う+お
 7  え  5       4       2

色々考えてみたのですが、手作業であれば、例えば元データをシートコピーして、数字を消して、足し算の式を入れて、値で貼り付けて、不要な行を消す…
で出来そうですが、マクロでやる場合、何か良い方法ありますでしょうか。
5行セットで同じ計算パターンの繰り返しなので、ループでうまく計算出来ないかなと思いますが、中々イメージがわかなくて…。
それか、計算の為の作業シートを用意し、B, D, F列の2〜6行目に数式（「あ」「え」「お」にはイコールで結ぶ、「い」と「う」には足し算する式）を入れておいて、B2〜F6セルの式をシートコピーした同じセルに貼り付け、最終行まで”オートフィル”する…とかなら、なんとか出来そうな気もしますが、作業シート無しのもっと簡単な方法ありましたら、ご教授頂ければと思います。

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

こんばんわ＾＾
色々方法は有るでしょうが、一案で
【い】を【あ】に
【お】は【う】に変換して、連想配列で同じキーは加算
を
お考えの様に5行間隔で回せば行けるかもですね。結果は
ジャグ配列にでも書き溜めて、最後に、入れ替えるなり、別の場所に
書き出す成り、ご随意に。。。＾＾ｖ
m(_ _)m
（隠居Z） 2022/11/03(木) 18:27:35
【い】を【あ】に
逆でしたね。すみません
（隠居Z） 2022/11/03(木) 20:27:17
ありがとうございます！
連想配列、ジャグ配列、、
dictionaryとかでしょうか。。
まだまだ初心者には初めて聞くワードで、大変そうです(^^;;
（ぽぽ） 2022/11/03(木) 21:52:40
規則性が簡単なので簡単な数式でも良いと思います。 

 Sub test()
    Dim ad1, ad2, ad3, ad4, s As String
    With Range("A1").CurrentRegion.Resize(, Cells(1, Columns.Count).End(xlToLeft).Column - 1).Offset(1, 1)
        ad1 = .Address(False, False)
        ad2 = .Offset(, -1).Resize(, 1).Address(False, True)
        ad3 = .Offset(-1).Address(False, False)
        ad4 = .Offset(2).Address(False, False)
'            IF(B2="",""        ,IF($A2="い",B2+ B1            ,IF($A2="う",B2+ B4            ,IF($A2="え",B2         ,""))))  'B2の数式
        s = "IF(adres1="""","""",IF(adres2=""い"",adres1+adres3,IF(adres2=""う"",adres1+adres4,IF(adres2=""え"",adres1,""""))))"
        s = Replace(s, "adres1", ad1)
        s = Replace(s, "adres2", ad2)
        s = Replace(s, "adres3", ad3)
        s = Replace(s, "adres4", ad4)
        .Value = Application.Evaluate(s)
        .Resize(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
 End Sub

（kazuo） 2022/11/03(木) 21:57:13

こんばんわ　＾＾
既に、スマートなご案内が御座いますが。言い出しべのコードなど作ってみました
ループさえあれば、何とか成ると思い込んでる、回し好きな老人が書くと
こんな感じです。。。ｗ。＾＾； 
 m(_ _)m
Option Explicit
Sub OneInstanceMain()
    Dim i             As Long
    Dim j             As Long
    Dim y             As Long
    Dim n             As Long
    Dim lc            As Long
    Dim lr            As Long
    Dim rAry()        As Variant
    Dim w()           As Variant
    Dim dk()          As Variant
    Dim idx()         As Variant
    Dim zD            As Object
    Dim sNm           As String
    With Worksheets("Sheet1")
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        rAry = .Range(.Cells(1), .Cells(lr, lc)).Value
        .Copy after:=Worksheets(1)
    End With
    sNm = ActiveSheet.Name
    Set zD = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(rAry, 1) Step 5
        For j = 0 To 4
            If rAry(i + j, 1) = "あ" Then rAry(i + j, 1) = "い"
            If rAry(i + j, 1) = "お" Then rAry(i + j, 1) = "う"
            If Not zD.Exists(rAry(i + j, 1)) Then
                zD(rAry(i + j, 1)) = Array(rAry(i + j, 2), rAry(i + j, 4), rAry(i + j, 6))
            Else
                w = zD(rAry(i + j, 1))
                w(0) = w(0) + rAry(i + j, 2)
                w(1) = w(1) + rAry(i + j, 4)
                w(2) = w(2) + rAry(i + j, 6)
                zD(rAry(i + j, 1)) = w
                Erase w
            End If
        Next
        DoEvents
        dk = zD.keys
        For y = LBound(dk) To UBound(dk)
            ReDim Preserve idx(n)
            idx(n) = Array(dk(y), zD(dk(y))(0), "", zD(dk(y))(1), "", zD(dk(y))(2))
            n = n + 1
        Next
        zD.RemoveAll
        Erase dk
    Next
    With Worksheets(sNm)
        .Cells.Clear
        .Cells(1).Resize(UBound(idx) + 1, UBound(idx(0)) + 1) = Application.Index(idx, 0, 0)
    End With
    Erase rAry, w, dk, idx
End Sub
（隠居Z） 2022/11/03(木) 23:38:33
kazuo様、隠居z様
大変素晴らしいコード、ありがとうございます。
このように数式に変換する事も出来るのですね。
どの範囲をad1-4に当てはまれば良いのか、まだ理解しきれていませんが、一つずつ分解してみます！

配列の方も、ありがとうございます！
こちらもまだ理解出来ていませんが、作業列なくてもいきますね。
一つずつ確認してみます。

今後の勉強の参考になります。
ありがとうございました。
（ぽぽ） 2022/11/04(金) 09:59:17

■１
＞5行セットで同じ計算パターンの繰り返しなので、ループでうまく計算出来ないかなと思いますが、中々イメージがわかなくて…。
まんまその発想でよいと思います。つまり、 
 A列の値が【あ】のとき・・・・1行下に加算貼り付け
 A列の値が【お】のとき・・・・2行上に加算貼り付け

とすればよいのではないでしょうか？

■２
踏まえてコード化すればこんな感じでしょう。（行の削除が絡むので下から上に見ていくのがミソです） 

    Sub さんぷる()
        Dim 行 As Long


        With ActiveSheet
            For 行 = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
                Select Case .Cells(行, "A").Value
                     Case "あ"
                        With .Cells(行, "A").Resize(, 6)
                            .[（セル範囲を）コピーする命令]
                            .Offset(1).[形式を選択して貼付する命令] Paste:=xlPasteValues, Operation:=xlAdd
                            .[セル範囲を削除する命令] Shift:=xlUp
                        End With


                    Case "お"
                        With .Cells(行, "A").Resize(, 6)
                            .[（セル範囲を）コピーする命令]
                            .Offset(-2).[形式を選択して貼付する命令] Paste:=xlPasteValues, Operation:=xlAdd
                            .[セル範囲を削除する命令] Shift:=xlUp
                        End With
                End Select
            Next 行
        End With
    End Sub

なお↓は【マクロの記録】で調べることができます。 

 [（セル範囲を）コピーする命令]
 [形式を選択して貼付する命令]
 [セル範囲を削除する命令]

（もこな２） 2022/11/04(金) 13:03:46

もこな2様
とってもシンプルで分かりやすい方法教えて頂き、ありがとうございます！
柔軟な発想が大切ですね。。
頭が固くて、いつも回りくどいやり方をしてしまいますが、引出しを増やしていきたいと思います。
大変ありがとうございます。 

    Sub さんぷる()
        Dim 行 As Long
        With ActiveSheet
            For 行 = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
                Select Case .Cells(行, "A").Value
                     Case "あ"
                        With .Cells(行, "A").Resize(, 6)
                            .Copy
                            .Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
                            .Delete Shift:=xlUp
                        End With
                    Case "お"
                        With .Cells(行, "A").Resize(, 6)
                            .Copy
                            .Offset(-2).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
                            .Delete Shift:=xlUp
                        End With
                End Select
            Next 行
        End With
    End Sub
（ぽぽ） 2022/11/04(金) 13:47:24
コメント返信：

[ 一覧(最新更新順) ]

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