VBAを使用した転記の件

商品名と値段が入力されている表Xと、商品名が縦方向に書いている表Yがあります。
マクロにて、表Yの商品"名欄の上から順に値段を表Xから転記していきます。複数ある場合は、横に追加していき、それが終わったら、次は商品"B"の行にいき、同じ処理を繰り返します。もし該当の値段がなかったら、そこは空欄のままとし、次の行に進み処理を繰り返します。検索する商品名がなくなったら処理は終了となります。添付が例です。よろしくお願いします。

No.4 ベストアンサー 回答者： tom04 回答日時： 2017/01/28 19:04

何度もごめんなさい。

投稿後もう一度結果を見てみると・・・
難しく考える必要はないように思えます。
単に並び替えだけでよいのでは？

Sub Sample3()
Dim wS As Worksheet
Set wS = Worksheets("Sheet2")
Worksheets("Sheet1").Range("B:C").Copy wS.Range("B1")
wS.Range("B1").Sort key1:=wS.Range("B1"), order1:=xlAscending, Header:=xlYes
End Sub

で同じ結果になります。

※　Sample2は出現順になりますが、
Sample3はB列の昇順としています。m(_ _)m

この回答へのお礼

そうですね・・・
ありがとうございました。

お礼日時：2017/01/28 20:51

No.3 回答者： tom04 回答日時： 2017/01/28 17:53

No.1・2です。

こちらで今一度確認してみました。
No.1の配置の画像の配置で問題なく動いたのですが・・・

もしかしてシートモジュールにしていませんか？
同じコードを標準モジュールにコピー＆ペーストし、シートモジュールを消去して
マクロを実行してみてください。m(_ _)m

No.2 回答者： tom04 回答日時： 2017/01/28 13:21

No.1です。

最初の質問とは全く異なるのですね？
配置は前回アップした画像通りだとします。

Sub Sample2()
Dim i As Long, lastRow As Long
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet1")
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
If lastRow > 2 Then
Range(.Cells(3, "B"), .Cells(lastRow, "C")).ClearContents
End If
lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
.Range("D:D").Insert
wS.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("D1"), unique:=True
For i = 2 To .Cells(Rows.Count, "D").End(xlUp).Row
wS.Range("B2").AutoFilter field:=1, Criteria1:=.Cells(i, "D")
Range(wS.Cells(3, "B"), wS.Cells(lastRow, "C")).SpecialCells(xlCellTypeVisible).Copy
.Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next i
wS.AutoFilterMode = False
Application.CutCopyMode = False
.Select
.Range("B2").Select
.Range("D:D").Delete
End With
Application.ScreenUpdating = True
End Sub

これではどうでしょうか？m(_ _)m

この回答へのお礼

最初の改良版の説明で申し訳ありませんでした。
早速試してみたのですが、
Range(.Cells(3, "B"), .Cells(lastRow, "C")).ClearContents
のところで下記のエラーが出ます。
実行時エラー’1004':
アプリケーション定義またはオブジェクト定義のエラーです。
すいません、当方VBA初心者の為、対処の仕方が分かりません。。。。

お礼日時：2017/01/28 15:58

No.1 回答者： tom04 回答日時： 2017/01/25 22:41

こんばんは！

↓の画像のような配置でも元データはSheet1にあり、Sheet2に表示するとします。
Sheet2のB列商品名はあらかじめ入力済みだという前提です。

Sub Sample1()
Dim i As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = 3 To wS.Cells(Rows.Count, "B").End(xlUp).Row
.Range("B2").AutoFilter field:=1, Criteria1:=wS.Cells(i, "B")
'↑　A列に項目名がある場合「field:=1」の「1」を「2」に変更★//
If .Cells(Rows.Count, "B").End(xlUp).Row > 2 Then
Range(.Cells(3, "C"), .Cells(lastRow, "C")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(i, "C").PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next i
Application.CutCopyMode = False
.AutoFilterMode = False
wS.Activate
wS.Range("B2").Select
End With
Application.ScreenUpdating = True
End Sub

※　画像のようにSheet1のA列項目名セルはなにも入っていないとします。
オートフィルタで処理していますので、A列に何らかの項目名が入っている場合は
コード内に記載しているようにフィルタの列を「2」に変更してください。m(_ _)m

この回答へのお礼

ありがとうございます。早速試してみましたら、できました。
追加で申し訳ないのですが、商品名"A"と"F"のように複数ある場合、横方向ではなく"A"の行を追加し、値段をC列に表示する(例でいうとB列に”商品名A"の行が5つできてC列に上から100、110、130、140、150)というようにするのは難しいでしょうか？？？

お礼日時：2017/01/28 10:44