How to filter based on strike-through formatting

[snickerbe3]

Hello,
I am using Excel 2010. I have a file with data in columns A to AB and about 15,000 rows of data. Any one or more cells per row may have strike-through formatting applied. I want to identify all records with any strike-through format applied, whether to one cell in the row or all cells in the row. My end goal is to separate any row with strike-through formatting to move these rows to a different worksheet. Any advice on how to accomplish this will be greatly appreciated!

Thank you in advance for your time!!

 

[Jobolobo]

Give this a go.

Sub StrikeOut()
Dim cll As Range
Dim rng As Range
Dim rC As Integer


rC = Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count 'Gets the last row to check
Set rng = Sheets("Sheet1").Range("A1:A" & rC) ' Sets the range to search through
For Each cll In rng
    If cll.Font.Strikethrough = True Or cll.Offset(0, 1).Font.Strikethrough = True Then 
        cll.Font.Strikethrough = True
        cll.Offset(0, 1).Font.Strikethrough = True
    End If
Next cll
End Sub

 

[Peter_SSs]

@Jobolobo
- I think you may have missed the fact that there are 28 columns, not just 2.
- I'm not sure how your code would actually help the OP filter off those rows that do have strikethrough?

@snickerbe3
- Text formatting is a poor way to deal with data manipulation! I'll assume you didn't set this up from scratch to have to do this job.
- With 28 columns and 15,000 rows, I think this will be quite a task.
- If a cell has strikethrough, will the whole cell text be strikethrough, or could you have in a cell "Red is <del>nice</del>" with just, say "nice" being strikethrough & the rest not?

 

[igold]

Hi,

How about something like this. This code assumes your data with the strikethroughs is Sheet1 and it will move the rows to Sheet2 starting at Cell A2. Please alter the references to suit your needs.

Please test this on a backup copy of your data as it will make changes to your data that are not easily reversible.

Sub cp_strikethrough()


    Dim lRow As Long, PlRow As Long
    Dim lCol As Long
    Dim r As Long, c As Long
    Dim cell
    
    Application.ScreenUpdating = False
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To lRow
        For Each cell In Range("a" & r, "AB" & r)
            cell.Select
            If cell.Font.Strikethrough = True Then
                PlRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
               cell.EntireRow.Cut Worksheets("Sheet2").Range("A" & PlRow + 1)
                Exit For
            End If
        Next
    Next
    Worksheets("Sheet1").Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
    
End Sub

HTH

igold

 

[Jobolobo]

@Peter_SSs
Apologies I misread the question, Was half way there though


This should put a strikethrough each row that has a cell with a strikethrough in it. Will further copy those rows to a new sheet (Sheet2 but will be inverted.)

Sub StrikeOut()
Dim rowCll As Range
Dim rowRng As Range
Dim rowMax As Integer
Dim colMax As Integer
Dim rowCount As Integer


rowMax = Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count + 1 'Gets the last row to check
colMax = Sheets("Sheet1").Range("A1").CurrentRegion.Columns.Count ' Gets the last column to check


Application.ScreenUpdating = False 'Stops screen from being updated (stops flickering between sheets)
For rowCount = 1 To rowMax 'Row range to check from the first row to last row
    Set rowRng = Sheets("Sheet1").Range(Cells(rowCount, 1), Cells(rowCount, colMax)) 'sets a range for the current row
    For Each rowCll In rowRng
        If rowCll.Font.Strikethrough = True Then
            rowRng.Font.Strikethrough = True
            rowRng.Copy 'Copys row
            Sheets("Sheet2").Range("A1").Insert Shift:=xlDown 'Inserts copied cells above previous cells (A1)
            Application.CutCopyMode = False
            Exit For
        End If
    Next rowCll
Next
Application.ScreenUpdating = True
End Sub

Apologies for my first attempt and misreading your question.

 

[Peter_SSs]

1. Assuming the whole (or at least the first character) of any cell with strikethrough is strikethrough, as igold's code does, then I'd make the following suggestion. For 15,000 rows with about 1 row in 10 containing a cell somewhere in the row with strikethrough, this code took <5 seconds v >24 seconds for post #4 code.

Notes:
a) I have assumed that Sheet2 exists with at least headings but any other data can be removed.
b) I have assumed column AC is available to use as a helper, & it is deliberate that I have included column AC in my coded range.

Post back with details if either of the above is not so.

Sub MoveIfWholeCellIsStrikethrough()
  Dim a As Variant
  Dim i As Long, j As Long, rws As Long, cols As Long
  
  Application.ScreenUpdating = False
  With Sheets("Sheet2").UsedRange.Offset(1)
    .Font.Strikethrough = False
    .ClearContents
  End With
  With Sheets("Sheet1")
    With .Range("A2:AC" & .Range("A" & .Rows.Count).End(xlUp).Row)
      ReDim a(1 To .Rows.Count, 1 To 1)
      rws = .Rows.Count
      cols = .Columns.Count - 1
      For i = 1 To rws
        For j = 1 To cols
          If .Cells(i, j).Font.Strikethrough Then
            a(i, 1) = 1
            Exit For
          End If
        Next j
      Next i
      .Columns(cols + 1).Value = a
      .Sort Key1:=.Columns(cols + 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      On Error Resume Next
      With .Columns(cols + 1).SpecialCells(xlConstants, xlNumbers).EntireRow
        .Resize(, cols).Copy Destination:=Sheets("Sheet2").Range("A2")
        .Delete
      End With
      On Error GoTo 0
    End With
  End With
  Application.ScreenUpdating = True
End Sub

2. If it may be that only part of a cell is strikethrough, then try the following code.

Notes:
a) This requires a lot more checking so will be considerably slower, see my further comments below.
b) The longer the text is in the cells, the slower the code.
c) The earlier a cell is found with strikethrough in the row, the faster the code.
d) The earlier any strikethrough is found within a cell's text, the faster the code.

My test data for this only had 3 or 4 characters per cell, with a single character somewhere randomly placed in 1 in 10 rows with strikethrough & the code took about 48 seconds to complete. Seemed slow but I guess still much faster than any manual method!

Sub MoveIfPartCellIsStrikethrough()
  Dim a As Variant
  Dim i As Long, j As Long, k As Long, rws As Long, cols As Long
  Dim bFound As Boolean
  
  Application.ScreenUpdating = False
  With Sheets("Sheet2").UsedRange.Offset(1)
   .Font.Strikethrough = False
   .ClearContents
  End With
  With Sheets("Sheet1")
    With .Range("A2:AC" & .Range("A" & .Rows.Count).End(xlUp).Row)
      ReDim a(1 To .Rows.Count, 1 To 1)
      rws = .Rows.Count
      cols = .Columns.Count - 1
      For i = 1 To rws
        bFound = False
        For j = 1 To cols
          For k = 1 To Len(.Cells(i, j).Text)
            If .Cells(i, j).Characters(k, 1).Font.Strikethrough Then
              a(i, 1) = 2
              bFound = True
            End If
            If bFound Then Exit For
          Next k
          If bFound Then Exit For
        Next j
      Next i
      .Columns(cols + 1).Value = a
      .Sort Key1:=.Columns(cols + 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      On Error Resume Next
      With .Columns(cols + 1).SpecialCells(xlConstants, xlNumbers).EntireRow
        .Resize(, cols).Copy Destination:=Sheets("Sheet2").Range("A2")
        .Delete
      End With
      On Error GoTo 0
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

@Peter_SSs
Apologies I misread the question, ..

Don't worry, we all do that from time-to-time, but somebody will virtually always pick you up on it here.

 

[igold]

Peter,

I did not particularly like that my code was looking at every cell, I knew it would be inherently slow. I had started out trying to look at the entire row with Range.find but could not figure out a way to come up with a doable Find What:=.

So I dropped back 10 yards and punted, if you catch my drift.

The code did execute as per the OP's original spec's so I threw it out there.

Thanks for the feedback on the time to execute!

igold

 

[Peter_SSs]

I did not particularly like that my code was looking at every cell,..

Well, it doesn't necessarily look at every cell does it? It appears to do the same as mine in that it looks at each cell in a row, but stops looking in that row as soon as it finds a 'cell of interest'.

I had started out trying to look at the entire row with Range.find ..

I also considered that but I was looking to do code for full cell strikethrough and partial and I don't think .Find will cut it with partial strikethrough so just opted straight for what I did. .Find is often a bit slow too, though I probably should have tested as in this circumstance with up to 28 cells to check each time, it might stack up okay.

The code did execute as per the OP's original spec's so I threw it out there.

Sure. Way to go.

 

[Peter_SSs]

... though I probably should have tested ..

Yep, should have. For the same data I timed in post #6, the following code took <1.5 seconds.

This code only finds rows where there is a cell with data that is all strikethrough.

Sub MoveIfWholeST_Find()
  Dim a As Variant
  Dim Rw As Range, st As Range
  Dim i As Long, j As Long, cols As Long
 
  Application.ScreenUpdating = False
  With Sheets("Sheet2").UsedRange.Offset(1)
    .Font.Strikethrough = False
    .ClearContents
  End With
  With Application.FindFormat
    .Clear
    .Font.Strikethrough = True
  End With
  With Sheets("Sheet1")
    With .Range("A2:AC" & .Range("A" & .Rows.Count).End(xlUp).Row)
      ReDim a(1 To .Rows.Count, 1 To 1)
      cols = .Columns.Count - 1
      For Each Rw In .Rows
        j = j + 1
        Set st = Nothing
        Set st = Rw.Find(What:="*", LookIn:=xlValues, SearchFormat:=True)
        If Not st Is Nothing Then a(j, 1) = 1
      Next Rw
      .Columns(cols + 1).Value = a
      .Sort Key1:=.Columns(cols + 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      On Error Resume Next
      With .Columns(cols + 1).SpecialCells(xlConstants, xlNumbers).EntireRow
        .Resize(, cols).Copy Destination:=Sheets("Sheet2").Range("A2")
        .Delete
      End With
      On Error GoTo 0
    End With
  End With
  Application.FindFormat.Clear
  Application.ScreenUpdating = True
End Sub