VBAで必要なものを別の場所に書き出す

VBAについて教えてください。
左側に名前、右側に商品名（50個）という表があります。

　　　商品名
名前　　紙　　　消しゴム　ペン ・・・・・・
Aさん　 2　　　 　0 　　　1　　　　
Bさん
Cさん

商品数が多くてエクセルで右の方まで追うのが手間なので、必要なものと数だけを左上のセルなどに一気に表示するVBAを作成したいです。
（Aさんという名前を入力して、GOボタンを押すと、下の方に商品名と個数が表示される）
※必要数が0個の物は表示不要です。

Aさん　［GO］　
下記に商品と必要数がが表示されるイメージです。
紙　　2
ペン　1

これを下記の場所の様な別場所に表示させたいです。

・オートシェイプの四角枠の中
・どこかの一つのセル（多いと見づらいかもしれないですが）
・どこかの場所にいくつかのセルを使って表示


沢山色々なサイトを探したのですが、VBA初心者で読んでもわからないことだらけでした。
勉強もしたいのですが、勉強する間もなく会社から求められておりまして急ぎ作成したいです。
もし教えて頂ける方がおりましたら幸いです。
ちょこちょこと手作業を自動化していきたいという方向ですが、会社はVBAなど使用できるものがおりませんので大変困っております。
よろしくお願いいたします。

No.2 ベストアンサー 回答者： tom04 回答日時： 2018/12/01 22:23

こんばんは！

一例です。
↓の画像のような配置で、元データはSheet1にあり、Sheet2に表示するようにしてみました。

＞Aさんという名前を入力して、GOボタンを押すと・・・
マクロを実行するとインプットボックスが表示され、検索したい名前を入力するようにしています。
標準モジュールにしてください。

Sub Sample1()
　Dim j As Long, cnt As Long
　Dim c As Range, myName As String
　Dim wS As Worksheet
　　Set wS = Worksheets("Sheet2")
　　myName = Application.InputBox("検索したい氏名を入力")
　　　With Worksheets("Sheet1")
　　　　Set c = .Range("A:A").Find(what:=myName, LookIn:=xlValues, lookat:=xlWhole)
　　　　　If Not c Is Nothing Then
　　　　　　wS.Range("A:B").ClearContents
　　　　　　wS.Range("A1") = myName
　　　　　　wS.Range("A2") = "商品名"
　　　　　　wS.Range("B2") = "数量"
　　　　　　cnt = 2
　　　　　　　For j = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　　　　　If .Cells(c.Row, j) <> 0 Then
　　　　　　　　　cnt = cnt + 1
　　　　　　　　　wS.Cells(cnt, "A") = .Cells(1, j)
　　　　　　　　　wS.Cells(cnt, "B") = .Cells(c.Row, j)
　　　　　　　　End If
　　　　　　　Next j
　　　　　Else
　　　　　　MsgBox "該当名なし"
　　　　　　Exit Sub
　　　　　End If
　　　End With
　　　　wS.Activate
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

時間はかかりましたが、解決することができました！
ありがとうございました。

お礼日時：2019/01/10 09:23

No.1 回答者： ママチャリ 回答日時： 2018/12/01 17:18

「沢山色々なサイトを・・・読んでもわからない」とのことですが、ここの回答を見ても分かるとは限りませんね～。

とりあえず、わたしの好みでサンプル作ってみました。解読してみて下さい。

Sub sample()
Dim lastCol As Long
Dim i As Long
Dim j As Long
Dim c As String
Columns("A:A").ClearComments
lastCol = Cells(2, Columns.Count).End(xlToLeft).Column
For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
c = ""
For j = 2 To lastCol
If Cells(i, j) <> 0 Then
c = c & Cells(2, j).Value & " " & Cells(i, j).Value & Chr(10)
End If
Next j
If c <> "" Then
With Cells(i, "A")
.AddComment
.Comment.Visible = False
.Comment.Text Text:=c
End With
End If
Next i
End Sub

この回答へのお礼

時間はかかりましたが、解決することができました！
ありがとうございました。

お礼日時：2019/01/10 09:23