VBA重新sorting和重复某些文本列
我有下面的原始数据表格：
1995（1）
（23:00）math0630
0830rest0930
1000英语1200
1200午餐1300
1330免费
我需要让它看起来像这样：
1995（1）（23:00）0630 Math 0830 0930 Math Break 1000 1200rest英语1200 1300英语午餐1300 1330午餐免费
现在我的macros代码有这样读：
1995（1）（23:00）math0630 0830rest0930 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 数据的屏幕截图
我很遗憾地说，我发现原来的代码很难处理，我无法在正确的地方获得与列到文本部分的数据。 因此，我为你的问题写了新的代码。 此代码将在您的屏幕截图上显示您的数据，并在第二张纸上输出，因为要运行工作簿的代码必须至less有两张纸。
而不是使用文本到列我使用splitfunction，所有的数据由“”（空格）分隔。 我已经考虑到一个活动由多于一个字组成的可能性。
在对一个项目（例如1530 Practice Test 1800 ）执行分割之后，检查数组元素的数量，如果数目大于3（0到2），则从数组中剥离时间（它们始终是第一个和最后一个元素），然后将其余元素连接起来，并将时间重新添加到位置0和2，将活动留在1中。
现在的产量现在每天都在一个很长的连续string中，因为我认为那是你的计划。 如果您希望将数据输出到不同单元中的每个项目，则可以在最后删除标记的代码。
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