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

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

ANo11です。

＞C5セルではなく、B5セルの間違いでした。
No11のサンプルではC5セルの内容で探すようになっているので、実行すると「登録されていません」の連発になってしまいますね。(^_^;)
とは言うものの、B5セルもコピー範囲内なので、列の位置が違うだけで、同じことになっていませんか？

いずれにしろ、検索値を指定しているのは
WorksheetFunction.Match(dataSht.Cells(5, 3).Text, dbSht.Columns(4), 0)
のところなので、そこで正しいセルを参照するようにしてあげれば、動作すると思います。

fujillin · Answer

ANo1です。

なんだか苦戦なさっているようですので、ご参考までに、こちらでもサンプルを作成してみました。
処理方法はNo1に記した手順に沿っています。
ご質問の内容を再確認したところ、元データのC5セルの内容は顧客名と一致しているはずですが、蓄積シートの欄へコピーする内容にも含まれていますよね？
ということは、結果として、顧客名別に蓄積する行の5列おきに（記載する必要のなさそうな）顧客名が繰り返し出てくることになり、蓄積シートの効率や一覧性が若干悪くなるような気がします。

・・・などということはさておいて、以下ではどうでしょうか？
※ エラー処理等は考慮していません。
　 ただし、顧客リストに参照値が無い場合がありそうなので、
　 これだけは対応しています。

Sub Sample()

Dim dataSht As Worksheet, dbSht As Worksheet
Dim rw As Long, col As Long

Set dataSht = Worksheets("Sheet1") '元データシート
Set dbSht = Worksheets("Sheet2") '蓄積用シート

'リストから顧客行を検索
On Error Resume Next
rw = WorksheetFunction.Match(dataSht.Cells(5, 3).Text, dbSht.Columns(4), 0)
If Err.Number = 1004 Then
　MsgBox "該当する顧客が登録されていません"
　Exit Sub
End If
On Error GoTo 0

'記入開始列を算出
col = dbSht.Cells(rw, Columns.Count).End(xlToLeft).Column
col = Int((col + 3) / 5) * 5 + 2
If col < 12 Then col = 12

'データ（5列分）をコピー
dataSht.Range("A5:E5").Copy
dbSht.Cells(rw, col).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

End Sub

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２の映像もつけておきます(小さくて見づらいと思いますが)。

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

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

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

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

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です。
ちょっと記入ミスがありました。

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

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

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

ANo11です。

ANo1です。

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

エラーがでるのは

そうですね。

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

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

No.2です。

No.2です。

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

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

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

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