ＶＢＡとデータの転記について

質問

今エクセル2003で、以下の上段画像のようなエクセルデータを作成しました。

上段（シート1）が、各商品に対する評価表なのですが、
そこに評価のあった件数が入力されています。

今、シート1の商品名から評価の不可までを、
ＶＢＡでシート2に以下のように転記をしたいのです。

先月はたまたま26件だったのですが、
毎月の商品の件数が、決まっていないので、連番記載とセルごとの処理
ループの使い方がよくわかりません。

評価欄は1件でも件数があれば、○印を転記して、空白はそのままで
転記したいのです。

データが多くなるにつれ手作業が大変になってきました。

ＶＢＡがまったくわからず、申し訳ありませんが
よろしくお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.1

keithin · ベストアンサー

特にループをする必要もありません。

sub Sample1()
　dim LastRow as long
　lastrow = worksheets("Sheet1").range("B65536").end(xlup).row
　if lastrow =1 then exit sub

　with worksheets("Sheet1").range("A2:A" & lastrow)
　　.formula = "=ROW(A1)"
　　.value = .value
　end with

　worksheets("Sheet2").cells.clearcontents
　worksheets("Sheet1").cells.copy destination:=worksheets("Sheet2").range("A1")
　on error resume next
　worksheets("Sheet2").range("D2:F" & lastrow).specialcells(xlcelltypeconstants).value = "○"
end sub

＃Sheet1と2の表の体裁がキチンと事前に準備できているときは，シート１から２に転記する部分を改善した方がよい
　よく判らないときはこのままで。

回答No.2

merlionXX

ではご要望によりLoopさせる方法の一例です。

Sub test01()
　　Dim ws(1 To 2) As Worksheet
　　Dim myC As Range
　　Dim i As Long, n As Long
　　Set ws(1) = Sheets("Sheet1")
　　Set ws(2) = Sheets("Sheet2")
　　Set myC = ws(1).Range("B2")
　　With ws(2)
　　　　.Cells.ClearContents
　　　　.Range("A1:F1").Value = ws(1).Range("A1:F1").Value
　　　　Do While myC.Value <> ""
　　　　　　i = i + 1
　　　　　　.Range(myC.Offset(0, -1).Address) = i
　　　　　　.Range(myC.Address) = myC.Value
　　　　　　For n = 1 To 4
　　　　　　　　.Range(myC.Offset(0, n).Address) = IIf(myC.Offset(0, n).Value <> "", "○", Empty)
　　　　　　Next n
　　　　　　Set myC = myC.Offset(1)
　　　　Loop
　　End With
End Sub