Moving marked text

[exceled]

Hey everyone,

Within each cell in a column there are different files, I want to move the ones that are marked into the column to the right leaving just the others. any idea how this can be done?

For example:


test123.doc
secondtest123.pdf
[MARK]thirdtest123.doc ---> [MARK]thirdtest123.doc
fourthtest123.doc


Result:

test123.doc
secondtest123. [MARK]thirdtest123.doc
pdffourthtest123.doc

 

[Dirkasaurus]

Put your active cell at the top of your column and run this routine. It will move those tagged with "[Mark]" to the next cell to the right of it's current location.

Sub MoveMarkedEntries()
Dim iRowCounter As Integer
iRowCounter = 0
Do Until Len(ActiveCell.Offset(iRowCounter, 0)) = 0
If Left(UCase(ActiveCell.Offset(iRowCounter, 0)), 6) = "[MARK]" Then
ActiveCell.Offset(iRowCounter, 1) = ActiveCell.Offset(iRowCounter, 0)
ActiveCell.Offset(iRowCounter, 0) = ""
End If
iRowCounter = iRowCounter + 1
Loop
MsgBox "Moving values complete.", vbOKOnly, "Success"
End Sub

 

[exceled]

That's perfect except some of the cells have more than one attachment, on different lines:

for example:

test123.doc
secondtest123.
[MARK]thirdtest123.doc
pdffourthtest123.doc

All in one cell

 

[Dirkasaurus]

To move any cell value that has [MARK] anywhere in the cell text I changed the condition for moving:

Sub MoveMarkedEntries()
Dim iRowCounter As Integer
iRowCounter = 0
Do Until Len(ActiveCell.Offset(iRowCounter, 0)) = 0
If Instr(UCase(ActiveCell.Offset(iRowCounter, 0)), "[MARK]")>0 Then
ActiveCell.Offset(iRowCounter, 1) = ActiveCell.Offset(iRowCounter, 0)
ActiveCell.Offset(iRowCounter, 0) = ""
End If
iRowCounter = iRowCounter + 1
Loop
MsgBox "Moving values complete.", vbOKOnly, "Success"
End Sub <!-- / message -->

 

[Rick Rothstein]

Does the following code do what you want? You would start be selecting all of the cells you want to process, then run this macro...

Sub MoveMARKedItems()
  Dim X As Long, Cell As Range, NewText As String, Lines() As String
  For Each Cell In Selection
    If InStr(1, Cell.Value, "[MARK]", vbTextCompare) Then
      Lines = Split(Cell.Value, vbLf)
      For X = 0 To UBound(Lines)
        If InStr(1, Lines(X), "[MARK]", vbTextCompare) = 1 Then
          NewText = NewText & vbLf & Mid(Lines(X), 7)
          Lines(X) = ""
        End If
      Next
      Cell.Offset(, 1).Value = Mid(NewText, 2)
      NewText = Join(Lines, vbLf)
      Do While InStr(NewText, vbLf & vbLf)
        NewText = Replace(NewText, vbLf & vbLf, vbLf)
      Loop
      Do While Right(NewText, 1) = vbLf
        NewText = Left(NewText, 1) = vbLf
      Loop
      Do While Left(NewText, 1) = vbLf
        NewText = Mid(NewText, 2)
      Loop
      Cell.Value = NewText
      NewText = ""
    End If
  Next