VBA Transpose Loop и начать новую строку при соблюдении критериев

Question

Мои данные разделены столбцом, и каждый день разделяется пустой строкой в ​​этой колонке. В принципе мне нужно VBA макросов, чтобы сделать эти данные:

1995 (1) 
(23:00) 

Math 0630 
0830 Break 0930 
1000 English 1200 
1200 Lunch 1300 

1995 (2) 
(12:45) 

Chemistry 0630 
0830 Lab 0930 
1000 Bio 1200 
1200 Lunch 1300 

появляется, как это в новом листе:

1995 (1) (23:00) Math 0630 0830 Break 0930 1000 English 1200 1200 Lunch 1300 
1995 (2) (12:45) Chemistry 0630 0830 Lab 0930 1000 Bio 1200 1200 Lunch 1300 

Я также нужен код VBA, чтобы отделить каждую строку, когда начинается новый день. Может кто-нибудь помочь?

Это то, что я до сих пор ..

Sub blnkrows() 
Do 
    p = p + 20 
    If Rows(p).Find("*") Is Nothing Then Exit Do 
Loop 
    y = Range(Rows(1), Rows(p)) 
    With Sheets("Sheet2") 
    Range(.Rows(1), .Rows(p)) = y 
    End With 
End Sub 

Но это только копирует данные на новый лист.

Answer 1

Это должно делать то, что вы просите

Редактировать этот код основан на личных беседах с ОП. Были идиосинкразии к шаблонам, которые требовали большего обзора.

Sub blnkrows() 
Dim arr() As Variant 
Dim p As Integer, i& 
Dim ws As Worksheet 
Dim tws As Worksheet 
Dim t As Integer 
Dim c As Long 
Dim u As Long 



Set ws = ActiveSheet 
Set tws = Worksheets("Sheet2") 
i = 1 
With ws 
Do Until i > 100000 
    u = 0 
    For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column 
     ReDim arr(0) As Variant 
     p = 0 
     t = 0 
      Do Until .Cells(i + p, c) = "" And t = 1 
       If .Cells(i + p, c) = "" Then 
        t = 1 

       Else 
        arr(UBound(arr)) = .Cells(i + p, c) 
        ReDim Preserve arr(UBound(arr) + 1) 
       End If 
       p = p + 1 
      Loop 

     If p > u Then 
      u = p 

     End If 
     If c = .Cells(1, .Columns.Count).End(xlToLeft).Column Then 
      If .Cells(i + p, c).End(xlDown).Row > 100000 And .Cells(i + p, 1).End(xlDown).Row < 100000 Then 
       i = .Cells(i + u, 1).End(xlDown).Row 
      Else 
       i = .Cells(i + p, c).End(xlDown).Row 
      End If 

     End If 
     tws.Cells(tws.Rows.Count, 1).End(xlUp).Offset(1).Resize(, UBound(arr) + 1) = arr 

    Next c 

Loop 
End With 
With tws 
    .Rows(1).Delete 
    For i = .Cells(1, 1).End(xlDown).Row To 2 Step -1 
     If Left(.Cells(i, 1), 4) <> Left(.Cells(i - 1, 1), 4) Then 
      .Rows(i).EntireRow.Insert 
     End If 
    Next i 
End With 
End Sub