VBA轉置循環並在滿足條件時開始新行

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

這應該做你在問什麼

編輯此代碼是基於私人談話與OP。對於需要更多評論的模式，有些特質。

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