[[20200201002837]]　『マクロ　不規則な行列入れ替えを繰り返したい』（スヌーピー）　ページの最後に飛ぶ

『マクロ　不規則な行列入れ替えを繰り返したい』（スヌーピー）

データの一部を行列入れ替えをして貼り付けを行っており、
入れ替えたい行の下に必要行数の空白を入れるマクロまでは出来たのですが、
そこから先がうまくいきません
どのようなVBAにすれば良いでしょうか？

やりたい事
R列にW列～AF列までの間にデータが入ってるものだけ行列置き換えて貼り付ける

下記表では
R2に「じゃがいも」　R3に「ピーマン」。
R8に「もも」R9に「すいか」R10に「みかん」R11に「ぶどう」R12に「さくらんぼ」　となります。

W列～AF列のデータ個数はA列の自然数+1　になります。

最終行数や空白行などはデータによって毎回変わります。

よろしくお願い致します。

 A	…	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF
 0		りんご	94	91	-3	0	0	0	0	0	0	0	0	0	0	0
 1		やさい	#N/A	#N/A	24	25	じゃがいも	ぴーまん	0	0	0	0	0	0	0	0

 0		トマト	58	46	-12	0	0	0	0	0	0	0	0	0	0	0
 0		にんじん	58	57	-1	0	0	0	0	0	0	0	0	0	0	0
 0		ぶどう	1	-1	-2	0	0	0	0	0	0	0	0	0	0	0
 0		きゃべつ	0	-2	-2	0	0	0	0	0	0	0	0	0	0	0
 3		くだもの	#N/A	#N/A	50	52	もも	すいか	みかん	ぶどう	さくらんぼ	0	0	0	0	0

 0		かき	#N/A	#N/A	-1	0	0	0	0	0	0	0	0	0	0	0

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

＞入れ替えたい行の下に必要行数の空白を入れるマクロまでは出来たのです

それを提示してください。

 Option Explicit

 Sub test()
    Dim c As Range
    Dim n As Long

    n = 1
    For Each c In Range("A1:A10")
        If c.Value > 0 Then
            Cells(c.Row, "W").Resize(, 10).Copy
            Cells(n, "R").PasteSpecial Transpose:=True
        End If
        n = n + c.Value + 1
    Next

 End Sub

（マナ） 2020/02/01(土) 05:22

新たなシートに転記していけば挿入は考えなくてもよくないですか？

古いシートが要らなければ削除してしまえばいいわけですし。。。

（まっつわん） 2020/02/01(土) 07:54

行挿入でしたか、
なら、これでよかったです。

 Option Explicit

 Sub test()
    Dim c As Range

    For Each c In Range("A1:A10")
        If c.Value > 0 Then
            Cells(c.Row, "W").Resize(, 10).Copy
            Cells(c.Row, "R").PasteSpecial Transpose:=True
        End If
    Next

 End Sub

（マナ） 2020/02/01(土) 07:58

＞.Resize(, 10)

ここも修正が必要でした。

（マナ） 2020/02/01(土) 08:05

マナさん　ありがとうございます。

＞入れ替えたい行の下に必要行数の空白を入れるマクロまでは出来たのです
＞それを提示してください。

空白行を追加するマクロは下記で処理してます。

Sub 空白行追加()

    Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        With Cells(i, 1)
            If VarType(.Value) = vbDouble And .Value > 0 Then
                If CLng(.Value) = .Value Then
                    Rows(i + 1 & ":" & i + .Value).Insert Shift:=xlDown
                End If
            End If
        End With
    Next
End Sub

マナさんのコードを試したのですが、これだと元々記入されていたR列の必要なデータまで
上書きされてしまいます。

上の例ですと、4行目のトマト　5行目にんじん　などは残したままにしたいんです。。

まっつわんさん　挿入までは、マクロで処理できてるので、別シートでも結局は行列入れ替えの貼り付けが必要になってしまいます。。
（スヌーピー） 2020/02/01(土) 13:22

 回答者のみなさん、良くこの質問に答えられますね。
 質問の意味がさっぱり解らないのだけれど・・・。
（BJ） 2020/02/01(土) 14:19

  こんにちは！

 回答しようとチャレンジしましたが、、さっぱりわかりませんでした。(^^;

 ご自身のBookでお試しになりたい気持ちはわかりますが、、こういう掲示板では、アドレスがすごく大切です。

 要は、、こういう事です。という例え話のサンプルを提示されてそれをご自身で応用された方がいいと思います。

 あと、不評ですけど、、レイアウトを作成するツールもあります。。。ご希望であれば、、、ですが、、、
（SoulMan） 2020/02/01(土) 14:29

.Resize(, c.Value)

これで問題ないなら、提示いただいた行挿入のマクロに組み込むとよいです。

（マナ） 2020/02/01(土) 14:42

 私がわからなかった点を少し。。。
 >下記表では 
 >R2に「じゃがいも」　R3に「ピーマン」。

 これは、
 りんご
 やさい
 のことですか？

 >R8に「もも」R9に「すいか」R10に「みかん」R11に「ぶどう」R12に「さくらんぼ」　となります。
 これも？？ですけど、、
 トマト
 にんじん
 ぶどう
 きゃべつ
 くだもの
 のことですか？

 あと、、↓この関係がよくわかりません。
 >W列～AF列のデータ個数はA列の自然数+1　になります。

 特にA列の　3　のところは　＋１だと　4　ですが、、
 >「もも」R9に「すいか」R10に「みかん」R11に「ぶどう」R12に「さくらんぼ」
 だと　5　つ　ですよね？？？

 それから、、R2　R3　ときて　なぜ？　R8　R9・・・・と飛ぶのですか？？？

 まぁ、、ご返信いただいてもお答え出来ないと思いますけど、、何かの足しにでもなれば幸いです。。。。
（SoulMan） 2020/02/01(土) 15:08

 SoulManさん　こんにちは

 ＞＞　あと、不評ですけど、、レイアウトを作成するツールもあります
なかなか便利なツールですよ　(#^^#)ｖ

 自然数って、たしか　1、以上の整数でしたかね。じゃや2以上の【整数】ってことっすかね
（？ｖ？）；え。。。
実数、負、正、整数、自然数。。。？？？？なにやら数学みたいな。。。＾＾；
解らなくなっってきました、最近、失態が多いので　←　もちろん私。これにて
失礼いたします。でわでわ　m(_ _)m
（隠居じーさん） 2020/02/01(土) 15:22

.Resize(, c.Value +1)

でした。

（マナ） 2020/02/01(土) 15:27

 隠居じーさん　さん　こんにちは！！！

 お馬ちゃんの合間に回答しようと思ったら、、全然、、さえなくて＿|￣|○です。(^^;

 >最近、失態が多いので

 いやいや、、ご活躍をチラッちっらっと陰ながら拝見しておりますですよ。。。

 引き続きご活躍を願っております。。。。

 では、、では、、また、、よろしくお願いします。(^^;
（SoulMan） 2020/02/01(土) 15:32

 あと、、W　X　Y　のとこは、、X　が　0　なので

 >R列にW列～AF列までの間にデータが入ってるものだけ行列置き換えて貼り付ける

 パス　するんでしょうね？？？　多分？？？
（SoulMan） 2020/02/01(土) 15:39

 A7セルは「4」のミスだとすると、
 オリジナルのコードに 以下の2行挿入すればいいんじゃないですか？

  If CLng(.Value) = .Value Then
      Rows(i + 1 & ":" & i + .Value).Insert Shift:=xlDown

      'ここに2行挿入
      Cells(.Row, "W").Resize(1, .Value + 1).Copy
      Cells(.Row, "R").PasteSpecial Paste:=xlPasteAll, Transpose:=True

  End If

（半平太） 2020/02/01(土) 16:02

　＞別シートでも結局は行列入れ替えの貼り付けが必要になってしまいます。。
そうですよ。
でも、
行を挿入するための労力が減る＆元データが壊れない
のでそっちの方がいいかなと思ったまでです。

行列の入れ替えは、ワークシート上で使う用に、用意されている、
「Transpose関数」
を使うと容易に行列の入れ替えが出来ます。
(形式を指定して貼り付けでもできますね。）

 Sub test()
    Dim r As Range      '行
    Dim c As Range      '行の一部のセル
    Dim n As Long       'データの数
    Dim i As Long       '最後の行までちゃんと見てるか検証用にループの回数を数えてみる

    For Each r In ActiveSheet.UsedRange.Rows
        i = i + 1
        Set c = r.Range("W1:AF1")
        With WorksheetFunction
            'W列からAF列までの文字列のデータの数を数える
            n = .CountA(c) - .Count(c)
            'もし､データが2つ以上あれば
            If n > 1 Then
                '行挿入
                r.EntireRow.Resize(n - 1).Offset(1).Insert
                '行列を入れ替えて値の転記
                r.Range("R1").Resize(n).Value = .Transpose(c)
            End If
        End With
    Next
    Debug.Print i   'イミディエイトウィンドウに結果を出力
 End Sub

（まっつわん） 2020/02/01(土) 16:14

＞（隠居じーさん） 2020/02/01(土) 15:22
＞（SoulMan） 2020/02/01(土) 15:32

回答者同士の挨拶はやめましょう。
質問者のみならず他の閲覧者にも不愉快を与え迷惑です。
（閲覧迷惑者） 2020/02/01(土) 22:10

Sub main()

    Dim i As Long, j As Long, c As Range, r As Range
    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        If Val(Range("A" & i).Value) > 0 Then
            For j = 0 To Val(Range("A" & i).Value)
                Rows(i + 1).Insert Shift:=xlDown
            Next j
            Set r = Range("R" & i + 1)
            For Each c In Range("S" & i & ":AF" & i)
                If Not (IsNumeric(c.Value) Or Left(c.Text, 1) = "#") Then
                    r.Value = c.Value
                    Set r = r.Offset(1)
                End If
            Next c
        End If
    Next i
End Sub
（mm） 2020/02/03(月) 14:20

説明がわかりづらく申し訳ございませんでした。
皆様のお力で、「まさにその通り」の処理ができるようになります。
ありがとうございます。
（スヌーピー） 2020/02/04(火) 18:10

コメント返信：

[ 一覧(最新更新順) ]

[[20200201002837]] 『マクロ 不規則な行列入れ替えを繰り返したい』（スヌーピー） ページの最後に飛ぶ

[[20200201002837]]　『マクロ　不規則な行列入れ替えを繰り返したい』（スヌーピー）　ページの最後に飛ぶ