VBAコードがいまいち

会社の端末移設作業を行っています。
エクセルブックに２シートがありシート１には社員の座席、名前、電話番号、PCの情報を入力しています。シート２には座席の平面図を手動で作成しています。平面図はいつも異なる為手動で作ります。
シート１のB列に座席番号を入力します。C列には電話番号、D列にはその他。それがR列まで続く。
※C列からR列までには情報がはいっている場合もない場合もある。
３０名の移動があれば、３０行の情報を入力する。
それをシート２の平面図に入れるコマンドが知りたいです
シート２平面図には３０名（今回は）のデスク番号だけを入力する。
ここからが知りたいコマンドになります。

シート１のB列の１行目に入力されている座席番号を参照し、シート２で同じ座席番号をrangeで検索し、見つけたらその座席番号の下にシート１のC列からR列の情報をシート２（該当の座席番号）の下のセルに転記したいです。必ずしもC〜R列まですべてが入力されているわけではないので、ない場合はスキップしR列まで処理をしてほしい。シート２は座席番号につめて転記したいです。
それをdountil でシート３０行（今回は）を転記したいです。又は３１行目が空白になるので、
そこで終了したいです。
例：シート２の平面図
b１　座席番号
b２　名前
b３　電話番号
b４　PC　情報
b５　等々



エラーコマンドと　msgboxは問題なく作動しています

宜しくお願いします。

質問者からの補足コメント

• 補足ですみません。
  10ますを1席と表しています。
  それ以上増える事はございません。
  よろしくお願いします。

    補足日時：2016/03/08 06:46

No.2 ベストアンサー 回答者： ママチャリ 回答日時： 2016/03/08 21:59

10マス固定であれが、こんな感じでしょうか。

でも、C〜R列がフルに埋まっていたら、10マス超えますよね。

Sub sample()
Dim I As Long
Dim TargetRange As Range

For I = 1 To Sheets("Sheet1").UsedRange.Rows.Count
If Sheets("Sheet1").Cells(I, "B") <> "" Then
Set TargetRange = Sheets("Sheet2").Cells.Find(Sheets("Sheet1").Cells(I, "B"), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not TargetRange Is Nothing Then
Sheets("Sheet2").Range(TargetRange.Offset(1), TargetRange.Offset(10)).Clear
With Sheets("Sheet1")
.Range(.Cells(I, "B"), .Cells(I, "R")).SpecialCells(xlCellTypeConstants, 23).Copy
End With
With Sheets("Sheet2")
TargetRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End With
End If
End If
Next I
End Sub

この回答へのお礼

ママチャリさん
どうもありがとうございます。
こちらのコードを入力し、試してみます。
又質問がありましたら、サポートお願いします。

お礼日時：2016/03/09 18:10

No.1 回答者： ママチャリ 回答日時： 2016/03/07 22:52

こんばんわ。

ママチャリです。rikuitoさんのやりたいことが、やっとわかりました。
シート2は座席表とのことですが、いくつかのセルを罫線で囲って、机を表すのでしょうか？
それを前提に質問ですが、張り付ける情報が机の範囲を超えている場合は、どうしますか？他の机の情報を上書きしてしまう可能性がありますが、それでも良いのでしょうか？
例えば、ひとつの机をセル結合で１セルにして、その中に情報を追加していくことも可能かと思います。
また、図形などを使って、机を表しても良いと思います。

まずは、上書きしてしまって良いのか？ダメな場合は、どう回避するのかを検討してみて下さい。

この回答へのお礼

そうです。10ますを一名の座席として表しています。上書きはダメです。よろしくお願いします。

お礼日時：2016/03/08 06:20