Geek Answers Handbook

Reorder and repeat specific text columns

After entering the text in the VBA columns, my data looks like this:

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

As soon as I run the rest of the code, my data looks like this:

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

To make it easier to understand, "0630 MATH 0830" is in one cell, etc. etc.

My problem now I need the data to look like this:

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

So basically timings for classes need to be moved, if that makes sense. My code is below. Any kind of help would be greatly appreciated.

 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
+5
source share
2 answers

If I understand your question correctly, you are looking for something like this:

 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

Of course, Worksheets(1).Range("C5:G5") will need to be adjusted to the actual location of the cells being converted.

0
source

Unconfirmed, but this should do the trick:

 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
0
source

More articles:


All Articles