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.
Rich (BB code):
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!
Rich (BB code):
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
