Question

I wonder whether someone may be able to help me please.

I have an Excel (2003) spreadsheet called ‘Input’ with data in columns B to N. What I would like to be able to do is if there is text in any of the cells in column B, I would like to copy the row but only columns ‘B’ ‘I’ and ‘N’ and paste them into my second spreadsheet called ‘Output’ at cell ref B2.

If at all possible, once the information has been pasted, I’d like to add the word ‘Scheduled site’ in column ‘E’ on the ‘Output’ sheet if the cells in column ‘B’ have text in them.

I’ve been doing this manually, and it takes quite some time to do.

I just wondered whether someone may be able to show me please how I can automate this.

Many thanks

Answer 1

if your data looks like below, and you text entries are not formulae, then this approach will be very fast as it exploits SpecialCells to avoid looping rows

Sub MoveEM2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets("Input")
Set ws2 = Sheets("Output")
On Error Resume Next
Set rng1 = ws1.Columns("B").SpecialCells(xlConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set rng2 = ws2.[b2]
rng1.Copy rng2
'copy column I to Output C2
rng1.Offset(0, 7).Copy rng2.Offset(0, 1)
'copy column N to Output d2
rng1.Offset(0, 12).Copy rng2.Offset(0, 2)
rng2.Offset(0, 3).Resize(rng1.Cells.Count, 1) = "Scheduled Site"
Application.ScreenUpdating = True
End Sub

[updated for further query]

Sub MoveEM()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Set ws1 = Sheets("Input")
    Set ws2 = Sheets("Output")
    On Error Resume Next
    Set rng1 = ws1.Range(ws1.[b4], ws1.Cells(Rows.Count, "B").End(xlUp)).SpecialCells(xlConstants)
    On Error GoTo 0
    If rng1 Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set rng2 = ws2.[b2]
    rng1.Copy
    rng2.PasteSpecial xlPasteValues
    'copy column I to Output C2
    rng1.Offset(0, 7).Copy
    rng2.Offset(0, 1).PasteSpecial xlPasteValues
    'copy column N to Output d2
    rng1.Offset(0, 12).Copy
    rng2.Offset(0, 2).PasteSpecial xlPasteValues
    rng2.Offset(0, 3).Resize(rng1.Cells.Count, 1) = "Scheduled Site"
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub