VBA横のデータを縦にする方法

日別に横に同じパターンの項目が並びます。（1-15）→シート名
これを別シート（予定15）に
A列　B列　C列　D列　E列
の順で下にデータを並べたいです。

９行目以下は空白ですが数式が入っております。
17行目以降に数字が入力されていることもあります。

最後はきれいに日付ごとに並べたいです。
ご教授いただければ幸いです。
よろしくお願いいたします。

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

• 申し訳ございませんでした。
  お返事いただきありがとうございます。
  一番左の列に日付が入っております。A列、N列、AA列・・・
  形式は①になります。

  
  No.2の回答に寄せられた補足コメントです。 補足日時：2019/11/08 10:15

• アップした表を確認しました。
  小さくて申し訳ございませんでした。
  お返事いただきましてありがとうございます。
  
  表を大きくしてみましたので、再度ご確認いただけましたら幸いです。

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2019/11/08 10:16

• ありがとうございます。
  集計表のA9には、元データのN2～R4までが続きます。
  その下にはAA2～AA3が続きます・・・。
  
  元データには数式が入っており、空白でも数式があります。
  最終はGN列の値が入っているセルまでが、集計表の一番下に入ります。
  
  説明不足で申し訳ございません。。。

  No.3の回答に寄せられた補足コメントです。 補足日時：2019/11/08 13:15

• すみません、、、。
  初めの7行のみ反映しておりまして・・・。
  数式も一緒にコピーされているのですが、値貼り付けがうれしいです・・・。
  追加追加で申し訳ございません。。。

  No.5の回答に寄せられた補足コメントです。 補足日時：2019/11/08 15:58

No.6 ベストアンサー 回答者： GooUserラック 回答日時： 2019/11/08 16:15

それでしたらこれはいかがでしょうか？

Sub Sample()

Dim 列 As Long
Dim 元 As Long
Dim 終 As Long
Dim 先 As Long
　Sheets("（予定15）").Cells.ClearContents
　Sheets("（1-15）").Select
　Range(Cells(1, 1), Cells(1, 13)).Copy
　Sheets("（予定15）").Cells(1, 1).PasteSpecial Paste:=xlPasteValues
　先 = 2
　列 = 1
　Do While Cells(1, 列).Value <> ""
　　If Cells(2, 列).Value <> "" Then
　　　終 = 16
　　　For 元 = 2 To 16
　　　　If Cells(元, 列).Value = "" Then
　　　　　終 = 元 - 1
　　　　　Exit For
　　　　End If
　　　Next
　　　Range(Cells(2, 列), Cells(終, 列 + 12)).Copy
　　　Sheets("（予定15）").Cells(先, 1).PasteSpecial Paste:=xlPasteValues
　　　先 = 先 + 終
　　End If
　　列 = 列 + 13
　Loop
　Application.CutCopyMode = False
　Sheets("（予定15）").Select
　Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes

End Sub

この回答へのお礼

出来ました！！！！！！！！！！！！！
何度も何度もありがとうございました！！！！！！！
ペコリ。

お礼日時：2019/11/08 16:47

No.5 回答者： GooUserラック 回答日時： 2019/11/08 15:55

No.3 No.4 同じものを載せてしまいました。

申し訳ございません。

こちらはいかがでしょうか？

Sub Sample()

Dim 列 As Long
Dim 元 As Long
Dim 終 As Long
Dim 先 As Long
　Sheets("（予定15）").Cells.ClearContents
　Sheets("（1-15）").Select
　Range(Cells(1, 1), Cells(1, 13)).Copy Sheets("（予定15）").Cells(1, 1)
　先 = 2
　列 = 1
　Do While Cells(1, 列).Value <> ""
　　If Cells(2, 列).Value <> "" Then
　　　終 = 16
　　　For 元 = 2 To 16
　　　　If Cells(元, 列).Value = "" Then
　　　　　終 = 元 - 1
　　　　　Exit For
　　　　End If
　　　Next
　　　Range(Cells(2, 列), Cells(終, 列 + 12)).Copy Sheets("（予定15）").Cells(先, 1)
　　　先 = 先 + 終
　　End If
　　列 = 列 + 13
　Loop
　Sheets("（予定15）").Select
　Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes

End Sub

No.4 回答者： GooUserラック 回答日時： 2019/11/08 14:26

こちらではいかがでしょうか？

Sub Sample()

Dim 列 As Long
Dim 終 As Long
Dim 先 As Long
　Sheets("（予定15）").Cells.ClearContents
　Sheets("（1-15）").Select
　終 = Range("A1").End(xlDown).Row
　Range(Cells(1, 1), Cells(終, 13)).Copy Sheets("（予定15）").Cells(1, 1)
　先 = 終 + 1
　列 = 14
　Do While Cells(1, 列).Value <> ""
　　終 = Cells(1, 列).End(xlDown).Row
　　If 終 > 16 Then 終 = 16
　　If 終 > 1 Then
　　　Range(Cells(2, 列), Cells(終, 列 + 12)).Copy Sheets("（予定15）").Cells(先, 1)
　　　先 = 先 + 終
　　End If
　　列 = 列 + 13
　Loop
　Sheets("（予定15）").Select
　Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes

End Sub

No.3 回答者： GooUserラック 回答日時： 2019/11/08 11:54

それでは以下の様な物はいかがでしょうか？

Sub Sample()

Dim 列 As Long
Dim 終 As Long
Dim 先 As Long
　Sheets("（予定15）").Cells.ClearContents
　Sheets("（1-15）").Select
　終 = Range("A1").End(xlDown).Row
　Range(Cells(1, 1), Cells(終, 13)).Copy Sheets("（予定15）").Cells(1, 1)
　先 = 終 + 1
　列 = 14
　Do While Cells(1, 列).Value <> ""
　　終 = Cells(1, 列).End(xlDown).Row
　　If 終 > 16 Then 終 = 16
　　If 終 > 1 Then
　　　Range(Cells(2, 列), Cells(終, 列 + 12)).Copy Sheets("（予定15）").Cells(先, 1)
　　　先 = 先 + 終
　　End If
　　列 = 列 + 13
　Loop
　Sheets("（予定15）").Select
　Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes

End Sub

No.2 回答者： GooUserラック 回答日時： 2019/11/05 04:24

多分、図の下の様にするのではないかと思うのですが？

①と②のどちらでしょうか？それとも全然違いますか？
見たところ日付の欄が無いようですが、一番左のブロックが「１日」一番右のブロックが「１５日」とかでしょうか？その場合はどこに日付を入れるのか？などが判るように結果の写真を提示していただけると良いと思います。

No.1 回答者： tatsu99 回答日時： 2019/11/04 17:50

すみません、画像が小さすぎてよくわかりません。

見やすい画像を提示していただけませんでしょうか。
（左半分と右半分を２回に分けて投稿すれば見やすくなるかと）