满足条件时 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