エクセルのマクロで別のシートにボタンで転記させる

Question

こんにちは。

一枚のsheet1のA5からE5の1行分を、別のsheet2に転記したいと思っています。
条件としては、ボタンで、sheet1で入力したC5の値をsheet2のD列から探し、探した値の右横にsheet1のA5からE5の1行分を転記したいと思っています。

イメージとしては、ある顧客にたいし、問い合わせのあった内容を、その都度データベースとして別シートに蓄積していく感じです。

ただ、sheet2のD列には、顧客の名前、Eから K列には、顧客の基本情報を入れてあるので、L列から5列ずつを1回分の問合せ内容として、sheet1に入力したものを転記、蓄積したいと考えています。

どのようなマクロをかいたらよいか、ご教授願えますでしょうか。
よろしくお願いいたします。

picopico_7 · Accepted Answer

「 '//データを貼り付ける列を取得」のことでしょうか？

2種類書いてありますが最初の方のコードはコメント化してあるので実際には無視されます。
なので2種類書く必要はないです。

正確に言うと修正した際に最初の処理をコメント化したものが残っている状態です。
コード修正後、やっぱり前の処理に戻したいということもあるのでDeleteで消さずにコメント化しておくと良いかもです。

fujillin · Answer

こんにちは

自作なさるなら、おおむね以下の手順で可能だと思います。
作らない場合は、どなたか親切な方が作ってくださるのを待てばよろしいかと思います。

1）顧客リストとなっている列（D列）から対象となる行を特定する
　ワークシート関数のMATCHなどを利用してもよいですし、リストを順にループで照合していってもできるはずです。

2）対象行の右端の列を求める
　対象行の右側に随時追加していくものと仮定すれば、現在使われている最大列を取得する必要があります。
　ご存知とは思いますが
　　Cells(対象行, Columns.Count).End(xlToLeft).Column
　のような形で求めることが可能です。

3）書き込み開始する列を求める
　L（12）、Q（17）・・・という5列おきの列が書き込みの最初の列となりますので、2）で求めた列より大きな列数で該当する列を計算します。（5で除して2余る列）

4）行と列を決定できたので、必要なデータ（シート1のA5～E5)を求めた位置にコピーします。

picopico_7 · Answer

こんにちは。

とても簡単ではありますがこんなのでも動くかと思います。
----------------------------------------------------------------------------------------------------
Sub aaa()
    
    '//---シート名を指定-----------
       Const SNM1 = "Sheet1"
       Const SNM2 = "Sheet2"
    '//----------------------------
       
    Dim strKSK    As String
    Dim dblRETU As Double
    Dim dblHARU As Double
    
    '//一致する社名を検索
    strKSK = Sheets(SNM1).Range("C5")
    intRETU = Application.WorksheetFunction.Match(strKSK, Sheets(SNM2).Range("D:D"), 0)
    
    '//データを貼り付ける列を取得
    Sheets(SNM2).Range("D" & intRETU).Select
    Selection.End(xlToRight).Select
    intHARU = ActiveCell.Column + 1
    
    '//貼り付け
    Sheets(SNM1).Range("A5:E5").Copy
    Sheets(SNM2).Cells(intRETU, intHARU).Select
    ActiveSheet.Paste
    
End Sub
----------------------------------------------------------------------------------------------------

ちなみに「 '//データを貼り付ける列を取得」では連続するデータの最終列番号を取得していますので途中に空白などが存在する場合にはうまく動きません。

こちらも認識違いなどあるかもしれないので何かありましたら補足下さい。

picopico_7 · Answer

No.2です。
ちょっと記入ミスがありました。

Dim dblRETU As Double
Dim dblHARU As Double
と変数の宣言をしているのにコードでは「intRETU」「intHARU」としてしまいました。
直して下さいませ。
失礼致しました。

picopico_7 · Answer

No.2です。
途中に空白が存在する可能性があるならばこうゆうのはどうでしょう？
-------------------------------------------------------------------------------
    '//データを貼り付ける列を取得
    Dim MaxCol As Double
    MaxCol = Columns.Count
    
    Sheets(SNM2).Cells(dblRETU, MaxCol).Select
    Selection.End(xlToLeft).Select
    dblHARU = ActiveCell.Column + 1
-------------------------------------------------------------------------------
「 '//データを貼り付ける列を取得」の箇所をそっくり上のコードに置き換えてみてください。
やっていることとしてはシートの最終列からデータの存在する列まで移動させて列番号を取得させています。
この場合の注意点としては毎回sheet1のE5には必ず何かデータを入力しておくことが前提となります。
入力を要するデータがなかった時は「(なし)」でも何でも良いのでデータを入れておくようにします。

繰り返し処理(Loop)などを使用してもう少しシステマチックにすることももちろん出来ますが、まずはこの辺から動かしてみてはいかがでしょう？
もし難易度が上がっても良いということでしたらお手伝いしますのでおっしゃって下さい。

コンパイルエラーに関しては無視しといてはいけないような気がしますが(笑)
というかほっといたら動かないのではないかな？と。
誰でも最初は全く分からないところから始めるものなので知識不足なことは全然恥ずかしくないですよ。
最初は苦労も多いですが頑張ってください。
という私もまだまだ勉強中の身です・・・(＾＾；

picopico_7 · Answer

No.2のコードではエラーが出なく、No.4のコードに置き換えたらエラーでたという事で良いでしょうか？
だとするとNo.3で記載した修正がされていないとか？
私の方では「intRETU」「intHARU」は全て「dblRETU」「dblHARU」に置換してあります。

picopico_7 · Answer

そしたらこのコードを追加してみてもらえますか？
↓    
Sheets(SNM2).Select

追加する場所は「Sheets(SNM2).Cells(dblRETU, MaxCol).Select」の前です。

-------------------------------------------------------------------------------
    '//データを貼り付ける列を取得
    Dim MaxCol As Double
    MaxCol = Columns.Count
    
    Sheets(SNM2).Select
    Sheets(SNM2).Cells(dblRETU, MaxCol).Select
    Selection.End(xlToLeft).Select
    dblHARU = ActiveCell.Column + 1
-------------------------------------------------------------------------------

picopico_7 · Answer

そうですね。
先ほどと同じように「Sheets(SNM2).Select」を「Sheets(SNM2).Cells(dblCOL, dblHARU).Select」の前に記入してみてください。

picopico_7 · Answer

エラーがでるのは
----------------------------------------------------------
    '//貼り付け
    Sheets(SNM1).Range("A5:E5").Copy
    Sheets(SNM2).Cells(dblRETU, dblHARU).Select
    ActiveSheet.Paste
----------------------------------------------------------
の「Sheets(SNM1).Range("A5:E5").Copy」ここでしたね？
失礼しました。
そしたら「この前に「Sheets(SNM1).Select」を追記してみてください。

ダメだったらエラーメッセージを教えてください。

picopico_7 · Answer

上書きされてしまいますか？
こちらで動かしているものでは顧客情報の横に追記されていってます。
とりあえずもう一度こちらのコードをすべて貼り付けますね。
(ペースト方法は値貼り付けに変えてあります)

----------------------------------------------------------
Sub aaa()
    
    '//---シート名と指定-----------
       Const SNM1 = "Sheet1"
       Const SNM2 = "Sheet2"
    '//----------------------------
       
    Dim strKSK  As String
    Dim dblRETU As Double
    Dim dblHARU As Double
    
    '//一致する社名を検索
    strKSK = Sheets(SNM1).Range("C5")
    dblRETU = Application.WorksheetFunction.Match(strKSK, Sheets(SNM2).Range("D:D"), 0)
    
'    '//データを貼り付ける列を取得
'    Sheets(SNM2).Range("D" & dblRETU).Select
'    Selection.End(xlToRight).Select
'    dblHARU = ActiveCell.Column + 1
    
    '//データを貼り付ける列を取得
    Dim MaxCol As Double
    MaxCol = Columns.Count
    
    Sheets(SNM2).Select
    Sheets(SNM2).Cells(dblRETU, MaxCol).Select
    Selection.End(xlToLeft).Select
    dblHARU = ActiveCell.Column + 1
    
    '//貼り付け
    Sheets(SNM1).Select
    Sheets(SNM1).Range("A5:E5").Copy
    Sheets(SNM2).Select
    Sheets(SNM2).Cells(dblRETU, dblHARU).Select
'    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues
    
End Sub
----------------------------------------------------------

2回実行させた時のsheet２の映像もつけておきます(小さくて見づらいと思いますが)。

エクセルのマクロで別のシートにボタンで転記させる

こんにちは

こんにちは。

No.2です。

No.2です。

No.2のコードではエラーが出なく、No.4のコードに置き換えたらエラーでたという事で良いでしょうか？

そしたらこのコードを追加してみてもらえますか？

そうですね。

エラーがでるのは

上書きされてしまいますか？

「 '//データを貼り付ける列を取得」のことでしょうか？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング