重新sorting并重复某些文本列
在对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
所以基本上这些课程的时间安排如果有意义的话，就需要被移动。 我的代码如下。 任何types的帮助将不胜感激。
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
如果我正确理解你的问题，那么你正在寻找这样的东西：
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")将不得不调整到要转换的单元格的实际位置。
未经testing，但这应该做的伎俩：
Sub MoveIt() Dim LastRow as Long, RowCol as Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For RowCol = 1 to LastRow Cells(1, RowCol).Value = Cells(RowCol, 1).Value Cells(RowCol, 1).Value = "" Next RowCol End Sub