[[20180517191418]] 『【マクロ】範囲内で最終列が異なる場合の左詰め貼』(K) ページの最後に飛ぶ

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

 

『【マクロ】範囲内で最終列が異なる場合の左詰め貼り付けの方法について』(K)

マクロにて下図のM1:M8のデータをA1:L:8の範囲内で左詰めに値貼りする方法をご教授頂けますと幸いです。
最終列を取得した場合、N列に縦一列で貼付されてしまう為、苦戦しております。

手動にて該当箇所への値貼りを実行する事も可能ですが、
転記ミス等を防止する為、マクロでの制御を検討しております。

※●へ転記され、その後同様に左詰めで数値を転記する予定となります。
※既に入力されている数値100はM1:M8で集計された数値の為、固定値ではありません。

	A	B	C	D	E	F	G	H	I	J	K	L	M
1	100	100	100	100	100	100	100	100	●				10
2	100	100	100	100	100	100	100	●					10
3	100	100	100	100	100	100	●						10
4	100	100	100	100	100	●							10
5	100	100	100	100	●								10
6	100	100	100	●									10
7	100	100	●										10
8	100	●											10

アドバイス頂けますと幸いです。
説明に不足がありましたらご指摘下さい。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


(データの個数+1)列目に貼付けるとよいです。

(マナ) 2018/05/17(木) 19:36


マナさん
早速のご返信ありがとう御座います。
最終列の取得にこだわり過ぎており、考えに至りませんでした。

重ねてのご依頼となり大変恐縮ですが、
サンプルコードを頂けますと幸いです。

お手数をお掛け致しますが、何卒よろしくお願い致します。
(K) 2018/05/17(木) 19:45


こんな感じです
 Option Explicit

 Sub test()
    Dim r As Range

    For Each r In Range("A1:M8").Rows
        MsgBox r.Row & "行目は" & WorksheetFunction.Count(r) + 1 & "列目に貼付"
    Next

 End Sub

(マナ) 2018/05/17(木) 19:52


Range("A1:L8").Rows

でした。

(マナ) 2018/05/17(木) 19:55


マナさん

ご返信有難う御座います。

実際にM1:M8を該当箇所へ転記する際はどのようなコードを組めば良いかご教授頂きたいです。
同シート内に任意の画像をボタンとして配置し、押下毎に転記される仕組みを構築したく存じます。

ご依頼ばかりとなり大変恐縮ですが、
お力添え頂けますと幸いです。

(K) 2018/05/17(木) 20:06


>最終列を取得した場合、N列に縦一列で貼付されてしまう為、苦戦しております。

現在のコードをみせていただけますか。

(マナ) 2018/05/17(木) 20:51


マナさん

下記にて実装致しましたが、
M1:M8がI列に転記され、空白行への左詰め転記が出来ない状態となっております。

Columns("M").Copy Columns(Cells(1, 1).End(xlToRight).Column + 1)

マクロは初心者に等しい為、上記コードを8行分記載すれば上手くいきますでしょうか。
Columns("M1").Copy Columns(Cells(1, 1).End(xlToRight).Column + 1)
Columns("M2").Copy Columns(Cells(2, 1).End(xlToRight).Column + 1)
Columns("M3").Copy Columns(Cells(3, 1).End(xlToRight).Column + 1)



お時間取らせてしまい申し訳御座いません。

(K) 2018/05/17(木) 21:03


こうですか

 Option Explicit

 Sub test()
    Dim r As Range

    For Each r In Range("A1:L8").Rows
        With r.Columns(r.Columns.Count + 1)
            .Copy r.Columns(WorksheetFunction.Count(r) + 1)
            .ClearContents
        End With
    Next

 End Sub

(マナ) 2018/05/17(木) 21:30


マナさん

想定していた挙動となりました!!
有難う御座います。

※M列については別途関数を挿入しておりました為、.ClearContentsを省く事とさせて頂きました。

お時間と労力を割いて頂き誠に有難う御座います。
(K) 2018/05/17(木) 21:44


>M列については別途関数を挿入しておりました為

では、値のみの転記でないと駄目なのでは?

(マナ) 2018/05/17(木) 21:52


 こんばんは!
ありゃ衝突しましたけど、何かの足しになれば、、、
想像力をMaxにして書いてみました。

 Option Explicit
Sub てすと()
Dim r As Range
For Each r In Range("M1:M8")
  r.Copy Range("L" & r.Row).End(xlToLeft).Offset(, 1)
Next
'Columns("M1").Copy Columns(Cells(1, 1).End(xlToRight).Column + 1)
'Columns("M2").Copy Columns(Cells(2, 1).End(xlToRight).Column + 1)
'Columns("M3").Copy Columns(Cells(3, 1).End(xlToRight).Column + 1)
End Sub

(SoulMan) 2018/05/17(木) 21:52


 うん?
 >※M列については別途関数を挿入しておりました為、.ClearContentsを省く事とさせて頂きました。 
 という事は、、、こうかな?

 Option Explicit
Sub てすと()
Dim r As Range
For Each r In Range("M1:M8")
    Range("L" & r.Row).End(xlToLeft).Offset(, 1).Value = r.Value
Next
'Columns("M1").Copy Columns(Cells(1, 1).End(xlToRight).Column + 1)
'Columns("M2").Copy Columns(Cells(2, 1).End(xlToRight).Column + 1)
'Columns("M3").Copy Columns(Cells(3, 1).End(xlToRight).Column + 1)
End Sub
(SoulMan) 2018/05/17(木) 22:05

マナさん
頂いたコードを改修するスキルが不足しており、
貼りつけた先の範囲を再度コピーし、値貼りを実効するコードを追加致しました。
※本当はM列を該当範囲に値貼りする事が望ましいのですが、これ以上お手間をお掛けするのも忍びないです。

SoulManさん
ご返信有難う御座います。
頂いたコードは手元に控えさせて頂き、活用させて頂きます。
(K) 2018/05/17(木) 22:14


値の転記はこうです。

貼付け先.Value=コピー元.Value

 Sub test()
    Dim r As Range

    For Each r In Range("A1:L8").Rows
        r.Columns(WorksheetFunction.Count(r) + 1).Value = r.Columns(r.Columns.Count + 1)
    Next

 End Sub

(マナ) 2018/05/17(木) 22:21


.Valueを足してください。

 r.Columns(WorksheetFunction.Count(r) + 1).Value = r.Columns(r.Columns.Count + 1).Value

でした。

(マナ) 2018/05/17(木) 22:30


マナさん

ご親切に対応頂き有難う御座います。
頂いたコードを最終版として活用させて頂きます。

非常に助かりました!!
(K) 2018/05/17(木) 22:34


	A	B	C	D	E	F	G	H	I	J	K	L	M
1	100	100	100	100	100	100	100	100					10
2	100	100	100	100	100	100	100						10
3	100	100		100	100	100							10
4	100	100	100	100	100								10
5	100		100	100									10
6	100	100	100										10
7	100	100											10
8													10

というように途中のデータが抜けていたり、0件の行があったりする
場合にも対応できるようにすると、

Private Sub Test()

    Dim r As Range
    For Each r In Range("M1:M8")
        With r.End(xlToLeft)
            If .Value = "" Then
                .Value = r.Value
            Else
                .Offset(, 1).Value = r.Value
            End If
        End With
    Next
End Sub
(hatena) 2018/05/17(木) 22:39

hatenaさん

ゼロ値・データ空欄を想定し、補足で作成頂きありがとう御座います。
(K) 2018/05/18(金) 11:46


コメント返信:

[ 一覧(最新更新順) ]


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