Copy from one sheet to another with strikethrough

[Manny Singh]

Hello Excel Masters,

I have attached a spreadsheet, I need to copy form tab "Document Register" to "Reporting", criteria of copying is that copy only if cell contains any text and ignore the blank, also there are some cells with strike-through that needs to be copied with strike-through, could you please help?

 

[Nebu]

Hi:

Try the following code.

Sub test()
Application.ScreenUpdating = False

Dim rng As Range, r As Range, c As Range, chk As Boolean

i& = Me.Cells(Rows.Count, 1).End(xlUp).row
Set rng = Me.Range("A3:E" & i)
k& = 2

For Each r In rng.Rows
    chk = True
    For Each c In r.Cells
        If c = vbNullString Then
            chk = False
            Exit For
        End If
    Next
 
    If chk = True Then
        r.copy
        Sheet1.Range("A" & k).PasteSpecial
        Application.CutCopyMode = False
        k = k + 1
   End If
Next

Application.ScreenUpdating = True
End Sub

BTW the formula on your Reporting Tab should be

=IF(OR(E2={"A","B","C","D","E","F"}),"Yes","") and
=IF(OR(E2={"0","1","2","3"}),"Yes","")

Thanks

 

[Manny Singh]

Hi Nebu,

Thanks for helping but the code is giving an error that data is not found, could you please attach the file with code in it. Appreciate your help, thanks.

 

[Nebu]

Hi:

Find the attached.

Thanks

 

[Manny Singh]

Hi Nebu,
Thanks for quick response, very smart and helpful.

Just one issued, the code is not copying the row if there is any blank cell in the row, I want to be able to copy all cell with content and exclude rows that are completely blank.

Could you please tweak your code, thanks a lot, I wish I could write programming like you.

 

[Nebu]

Hi:

Try the following code.

Sub test()
Application.ScreenUpdating = False

i& = Me.Cells(Rows.Count, 1).End(xlUp).Row
k& = 2

For r = 3 To i
  m& = WorksheetFunction.CountA(Range("A" & r & ":E" & r))
 
  If m > 0 Then
        Range("A" & r & ":E" & r).Copy
        Sheet1.Range("A" & k).PasteSpecial
        Application.CutCopyMode = False
        k = k + 1
  End If
Next

Application.ScreenUpdating = True
End Sub

Thanks

 

[Manny Singh]

Hi Nebu,

I hope you are not getting annoyed but when I copied this code to the sheet, it's giving an error: "sub not defined".

Could you please help, sorry for the trouble. Thanks.

 

[Nebu]

Hi:

Find the attached.

Thanks

 

[Manny Singh]

Thank Nebu, very kind mate.