【エクセルVBA】抽出データからのデータ転記について上手くいきません。

発注担当退職に伴い下記エクセルシートでの発注書作成を引継ぎましたが
不明な点が改善出来ず、途方に暮れています。皆様のお知恵をお借りしたく
何卒、よろしくお願いいたします。

作業の流れは下記の通りです。
　１．別のＢＯＯＫから基本データを抽出して〔sheet2〕シートへ貼り付け。
　２．抽出データを〔発注書〕シートに必要データを転記して店名（会社）
　　　ごとに発注書シートを自動作成していく。
　　　その後、別マクロで保存先へ保存しています。

不明な点は同じ店名（会社名）が３つ以上抽出された場合に２つ分しか
転記されないところです。（毎月多いところで最大４つくらいになります）
抽出データから転記するマクロを調べましたが私では力不足で。。。。。
----------------------------------------------------------------------------------------------
ご参考1　同book　〔sheet2〕シートへの抽出結果
　Ａ列（日付）　Ｂ列（店名）　Ｃ列（時間）　Ｄ列（会社名）
１　　５月１日　　　東京店　　　２２：００　　東京株式会社
２　　５月３日　　　東京店　　　２３：００　　東京株式会社
３　　５月８日　　　東京店　　　２１：００　　東京株式会社
４　　５月８日　　　博多店　　　２１：００　　博多株式会社
５　　５月９日　　　博多店　　　２２：００　　博多株式会社
６　　５月３日　　　岡山店　　　２３：００　　岡山株式会社
７　　５月２日　　　横浜店　　　２１：００　　岡山株式会社
８　　５月１日　　　大阪店　　　２２：００　　大阪株式会社
９　　５月４日　　　大阪店　　　２３：００　　大阪株式会社
１０　５月６日　　　大阪店　　　２３：００　　大阪株式会社
　　　　・　　　　　　・　　　　　　・　　　　　　・
　　　　・　　　　　　・　　　　　　・　　　　　　・
----------------------------------------------------------------------------------------------
ご参考2　同book　〔発注書〕シート中段転記先の内容
　Ｆ列（区分）　Ｉ列（日付）　Ｐ列（時間）　Ｙ列（数量）
２３　　勤務　　　空白セル　　　空白セル　　　　１名　
２４　空白セル　　空白セル　　　空白セル　　　空白セル
２５　空白セル　　空白セル　　　空白セル　　　空白セル
　　　　・　　　　　　・　　　　　　・　　　　　　・
　　　　・　　　　　　・　　　　　　・　　　　　　・

ご参考3　同book　〔発注書〕シート下段転記先の内容
　Ａ列（日付）　　Ｏ列（時間）　Ｙ列（内容）
３７　空白セル　　　空白セル　　　現場対応
３８　空白セル　　　空白セル　　　空白セル
３９　空白セル　　　空白セル　　　空白セル
　　　　・　　　　　　・　　　　　　・　　
　　　　・　　　　　　・　　　　　　・　　
----------------------------------------------------------------------------------------------
ご参考4　発注書への転記マクロの内容
'抽出データから転記
'***************
Dim tenmei_new
Dim tenmei_old
Dim tanto_data
Dim lower_limit
Dim x, flag1

lower_limit = Worksheets(2).Range("A65536").End(xlUp).Row
flag1 = 1

For x = 1 To lower_limit
If Worksheets(2).Range("D" & x) = tanto Then
tenmei_new = Worksheets(2).Range("B" & x)

'シートのコピー
If tenmei_new <> tenmei_old Then
Worksheets("発注書").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = tenmei_new

'転記
Range("F13") = tenmei_new
Range("A2") = tanto
Range("I23") = Worksheets(2).Range("A" & x)
Range("P23") = Format(Worksheets(2).Range("C" & x), "hh:mm")
Range("A37") = Worksheets(2).Range("A" & x)
Range("O37") = Format(Worksheets(2).Range("C" & x), "hh:mm")

tenmei_old = tenmei_new
Else
Range("I24") = Worksheets(2).Range("A" & x)
Range("P24") = Format(Worksheets(2).Range("C" & x), "hh:mm")
Range("F24") = "勤務"
Range("Y24") = "1名"

Range("A38") = Worksheets(2).Range("A" & x)
Range("O38") = Format(Worksheets(2).Range("C" & x), "hh:mm")
Range("Y38") = "現場対応"


End If
End If
Next x
----------------------------------------------------------------------------------------------

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

• t_fumiakiさん。おっしゃる通りです。発注書に残るのは１番目と最後のデータです。元々期間として転記してたのかもしれません。ただ、発注書的には具合が悪いので３つある場合は３つとも転記出来ないかと思ってる次第です。転記先のセルは下段に空白セルが何段か余ってますので。。。コードをどう変えれば良いのかが分かりません。。。

    補足日時：2017/06/01 14:51

• t_fumiakiさん、ありがとうございます！　３つ目はF25、４つ目はF26…と１つずつ下へ行きます。
  ちなみに下段の方の転記先もそれぞれ同列で１つずつ下へ行きます。どうでしょうか。。。

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/06/01 15:32

No.3 ベストアンサー 回答者： t_fumiaki 回答日時： 2017/06/01 16:00

このコミュは字下げが出来ないので、見易く、先行空白を-にして有ります。

実際には半角空白で置き換えて下さい。
idxと言う変数を使い、1行ずつ下げたセルに転記する様にしています。


Dim tenmei_new
Dim tenmei_old
Dim tanto_data
Dim lower_limit
Dim x, flag1,idx

lower_limit = Worksheets(2).Range("A65536").End(xlUp).Row
flag1 = 1
idx=0

For x = 1 To lower_limit
-If Worksheets(2).Range("D" & x) = tanto Then
--tenmei_new = Worksheets(2).Range("B" & x)

---'シートのコピー
---If tenmei_new <> tenmei_old Then
----Worksheets("発注書").Copy After:=Sheets(Sheets.Count)
----ActiveSheet.Name = tenmei_new

----'転記
----Range("F13") = tenmei_new
----Range("A2") = tanto
----Range("I23") = Worksheets(2).Range("A" & x)
----Range("P23") = Format(Worksheets(2).Range("C" & x), "hh:mm")
----Range("A37") = Worksheets(2).Range("A" & x)
----Range("O37") = Format(Worksheets(2).Range("C" & x), "hh:mm")

----tenmei_old = tenmei_new
---Else

----Range("I" & 24+idx ) = Worksheets(2).Range("A" & x)
----Range("P" & 24+idx ) = Format(Worksheets(2).Range("C" & x), "hh:mm")
----Range("F" & 24+idx ) = "勤務"
----Range("Y" & 24+idx ) = "1名"

----Range("A" & 38+idx ) = Worksheets(2).Range("A" & x)
----Range("O" & 38+idx ) = Format(Worksheets(2).Range("C" & x), "hh:mm")
----Range("Y" & 38+idx ) = "現場対応"
----idx = idx+1

---End If
-End If
Next x

この回答へのお礼

素晴らしいです！思ってた通りの結果が得られます。t_fumiakiさん、この度は大変お世話になりました。ありがとうございます！！

お礼日時：2017/06/01 16:37

No.2 回答者： t_fumiaki 回答日時： 2017/06/01 15:22

3つとも出来ます。

2つ目の"勤務"を転記するセルがF24です。

3つ目はＦ幾つですか？

4個目も有るのでしたら、4個目はＦ幾つですか？

これを教えて貰えれば、相対的に解るので、コードを修正できます。

No.1 回答者： t_fumiaki 回答日時： 2017/06/01 14:12

そうなってますよ。

何か意味があるのでは無いですか。
店名が変化した場合と、同じ場合で処理が異なります。
東京
東京
東京
と並んでいる場合。

最初の東京で
F13、A2、I23、P23、A37、O37にだけ転記して

2番目、3番目の東京では
I24、P24、F24、Y24、A38、O38、Y38、だけに上書き転記しています。

発注書シートに何か制約があるのでは無いですか？