[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【マクロ】範囲内で最終列が異なる場合の左詰め貼り付けの方法について』(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 >
(マナ) 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
でした。
(マナ) 2018/05/17(木) 19:55
ご返信有難う御座います。
実際にM1:M8を該当箇所へ転記する際はどのようなコードを組めば良いかご教授頂きたいです。
同シート内に任意の画像をボタンとして配置し、押下毎に転記される仕組みを構築したく存じます。
ご依頼ばかりとなり大変恐縮ですが、
お力添え頂けますと幸いです。
(K) 2018/05/17(木) 20:06
現在のコードをみせていただけますか。
(マナ) 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
では、値のみの転記でないと駄目なのでは?
(マナ) 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
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
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
ゼロ値・データ空欄を想定し、補足で作成頂きありがとう御座います。
(K) 2018/05/18(金) 11:46
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.