vba - 重新排序并重复某些文本列

Question

对列 VBA 执行文本操作后，我的数据如下所示:

1995 (1)
(23:00)

Math 0630 
0830 Break 0930 
1000 English 1200 
1200 Lunch 1300 
1330 Free

运行其余代码后，我的数据如下所示:

1995 (1) (23:00) 0630 Math 0830 0930 Math Break 1000 1200 Break English 1200 1300 English Lunch 1300 1330 Lunch Free

为了更容易理解“0630 MATH 0830”在一个单元格中，依此类推。

我现在的问题是我需要数据如下:

1995 (1) (23:00) Math 0630 0830 Break 0930 1000 English 1200 1200 Lunch 1300 1330 Free

所以基本上，如果有意义的话，类(class)的时间需要调整。我的代码如下。任何类型的帮助将不胜感激。

Sub Macro4() ' ' Macro4 Macro '

'
    Sheets("Sheet2").Select
    Cells.Select
    Range("D29").Activate
    Selection.ClearContents
    Selection.End(xlUp).Select
    Selection.End(xlToLeft).Select
    Sheets("Sheet1").Select


'
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(16, 1), Array(21, 1), Array(37, 1), _
        Array(42, 1), Array(58, 1), Array(63, 1), Array(79, 1), Array(84, 1), Array(100, 1), Array( _
        105, 1), Array(121, 1), Array(129, 1)), TrailingMinusNumbers:=True
    Rows("1:6").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    Columns("F:F").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Selection.Delete Shift:=xlToLeft

Dim lastRow&, g& Dim findStr$

findStr = "Planning of"

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For g = lastRow To 1 Step -1 ' change this to 2 if you have headers
    If Cells(g, 1).Value = findStr Then
        'Range(Rows(i), Rows(i - 4)).Select
        Range(Rows(g), Rows(g - 4)).EntireRow.Delete
    End If Next g

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
        'If c = .Cells(1, .Columns.Count).End(xlToLeft).Column And .Cells(i, c) <> "" Then
        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

' ' Macro6 Macro '

'
    Sheets("Sheet2").Select
    Range("A1:M67").Select
    Selection.Copy
    Sheets("Output").Select
    Range("A3").Select
    ActiveSheet.Paste
    Range("A1").Select End Sub

Answer 1

如果我正确理解你的问题，那么你正在寻找这样的东西:

Option Explicit

Sub ReOrderAllDataInAllCells()

Dim rngCell As Range

For Each rngCell In Worksheets(1).Range("C5:G5")
    rngCell.Value2 = ReorderDataInCells(rngCell.Value2)
Next rngCell

End Sub


Public Function ReorderDataInCells(strUnsorted As String) As String

Dim strTemp As String

strTemp = strUnsorted
strTemp = Replace(strTemp, Split(strUnsorted, " ")(0), "")
If IsNumeric(Split(strUnsorted, " ")(UBound(Split(strUnsorted, " ")))) Then
    strTemp = Replace(strTemp, Split(strUnsorted, " ")(UBound(Split(strUnsorted, " "))), "")
End If
strTemp = Trim(strTemp) & " " & Split(strUnsorted, " ")(0) & " "
If IsNumeric(Split(strUnsorted, " ")(UBound(Split(strUnsorted, " ")))) Then
    strTemp = strTemp & Split(strUnsorted, " ")(UBound(Split(strUnsorted, " ")))
End If
ReorderDataInCells = strTemp

End Function

当然，Worksheets(1).Range("C5:G5") 必须调整为要转换的单元格的实际位置。