Question

我有以下原始数据表：

1995（1）
  （23:00）

数学0630
  0830 Break 0930
  1000英语1200
  1200午餐1300
  1330免费

我需要这样读：

1995（1）（23:00）0630数学0830 0930数学休息1000 1200休息英语1200 1300英语午餐1300 1330免费午餐

现在我的宏代码的内容如下：

1995（1）（23:00）数学0630 0830休息0930 1000英语1200 1200午餐1300 1330免费

这是我的代码：

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

数据截图：

Screenshot of Data

Answer 1

我很遗憾地说我发现原始代码很难处理，我无法使用列到文本部分将数据放在正确的位置。因此，我为您的问题编写了新代码。此代码将在您在屏幕截图中显示时显示您的数据，并将在第二张纸上输出，因为运行工作簿的代码必须至少有2张。

我使用split函数代替将文字用于列，所有数据都由＆＃34;分隔。＆＃34; （空间）。我考虑过一个由一个以上单词组成的活动的可能性。
对物品进行分割后，例如1530 Practice Test 1800，检查数组元素的数量，如果数字大于3（0到2），则从数组中剥离时间（它们始终是第一个和最后一个元素），其余元素然后加入，并在时间0和2重新添加时间，将活动保留为1。

由于我认为这是你的计划，因此每天输出一个长连续字符串。如果您希望使用不同单元格中的每个项目输出数据，则可以删除末尾标记的代码。

Sub GetSchedules()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim DataWs As Worksheet, OutputWS As Worksheet
    Dim DataArray() As String, temp1 As String, temp2 As String, temp3 As String
    Dim i As Long, j As Long, k As Long, l As Long, m As Long
    Dim EmptyRows As Long, WorkingRow As Long, StartRow As Long, EndRow As Long, NextStartRow As Long, FinalRow As Long

    Set DataWs = ThisWorkbook.Worksheets(1)
    Set OutputWS = ThisWorkbook.Worksheets(2)

    StartRow = 1: l = 1: FinalRow = 1

    Do Until StartRow > FinalRow
        For i = 1 To DataWs.Cells(StartRow, DataWs.Columns.Count).End(xlToLeft).Column
            EmptyRows = 0
            WorkingRow = StartRow
            Do Until EmptyRows = 2
                If DataWs.Cells(WorkingRow, i) = Empty Then
                    EmptyRows = EmptyRows + 1
                End If
                WorkingRow = WorkingRow + 1
            Loop
            EndRow = WorkingRow - 2

            If WorkingRow > NextStartRow Then NextStartRow = WorkingRow

            If DataWs.Cells(DataWs.Rows.Count, i).End(xlUp).Row > FinalRow Then
                FinalRow = DataWs.Cells(DataWs.Rows.Count, i).End(xlUp).Row
            End If

            m = 1
            For j = StartRow To EndRow
                DataArray() = Split(DataWs.Cells(j, i), " ")
                If UBound(DataArray) > 2 Then
                    temp1 = DataArray(0)
                    temp2 = DataArray(UBound(DataArray))
                    DataArray(0) = Empty
                    DataArray(UBound(DataArray)) = Empty
                    temp3 = Join(DataArray, " ")
                    ReDim DataArray(2)
                    DataArray(0) = temp1
                    DataArray(1) = temp3
                    DataArray(2) = temp2
                End If

                For k = 0 To UBound(DataArray)

                    OutputWS.Cells.NumberFormat = "@"
                    If m < 4 Then
                        OutputWS.Cells(l, m).Value = DataArray(k)
                    ElseIf m < 7 Then
                        If IsNumeric(DataArray(k)) Then
                            OutputWS.Cells(l, m - 2).Value = DataArray(k)
                        Else
                            OutputWS.Cells(l, m + 1).Value = DataArray(k)
                            OutputWS.Cells(l, m + 4).Value = DataArray(k)
                            m = m + 1
                        End If
                    Else
                        If IsNumeric(DataArray(k)) And k = 0 Then
                            OutputWS.Cells(l, m - 1).Value = DataArray(k)
                        ElseIf IsNumeric(DataArray(k)) And k = 2 Then
                            OutputWS.Cells(l, m - 3).Value = DataArray(k)
                        ElseIf Not IsNumeric(DataArray(k)) Then
                            OutputWS.Cells(l, m + 1).Value = DataArray(k)
                            If Not UBound(DataArray) = 1 Then OutputWS.Cells(l, m + 4).Value = DataArray(k)
                            m = m + 1
                        End If
                    End If
                    m = m + 1
                Next k
            Next j
            OutputWS.Cells(l, m - 3).Value = OutputWS.Cells(l, m - 4)
            OutputWS.Cells(l, m - 4).Value = OutputWS.Cells(l, m - 7)
            l = l + 1
        Next i
        StartRow = NextStartRow
    Loop

    Dim ResultArray() As String

    'If you want every item in a different cell rather than one long continuous string,
    'remove the code from the next "With OutputWs" to the next "End With"
    With OutputWS
        For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
            ReDim ResultArray(1 To .Cells(i, .Columns.Count).End(xlToLeft).Column)
            For j = 1 To .Cells(i, .Columns.Count).End(xlToLeft).Column
                ResultArray(j) = .Cells(i, j)
            Next j
            .Rows(i).ClearContents
            .Cells(i, 1) = Join(ResultArray, " ")
        Next i
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

VBA重新排序并重复某些文本列

1 个答案: