How to Copy Certain Cells From One Page to Another Based on a Key Word?

[Timberwolf]

Hi all

I have "borrowed" a VBA from the internet and I am trying to alter it to make it do what I need. What I want it to do is look on page "LX" in column A for the word "current" and if it finds it then copy certain cells from that row to the sheet "In Service"

I made some changes and I can get the whole row to copy but can I get just cells B,C,H,I,J,K,L,M only. Here is the current code. Any help would be very much appreciated.

Sub SearchForString()


    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer


    On Error GoTo Err_Execute


    
    LSearchRow = 5


    
    LCopyToRow = 2


    While Len(Range("A" & CStr(LSearchRow)).Value) > 0


        
        If Range("A" & CStr(LSearchRow)).Value = "Current" Then


        
            Rows(CStr(LSearchRow) & "B:L" & CStr(LSearchRow)).Select
            Selection.Copy


        
            Sheets("In Service").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste


        
            LCopyToRow = LCopyToRow + 1


           
            Sheets("LX").Select


        End If


        LSearchRow = LSearchRow + 1


    Wend


   
    Application.CutCopyMode = False
    Range("A3").Select


    MsgBox "All matching data has been copied."


    Exit Sub


Err_Execute:
    MsgBox "An error occurred."


End Sub

 

[PCL]

Can you give more details please:
then copy certain cells from that row to the sheet "In Service"
Where to paste the cells, after the last row ??

 

[Fluff]

Untested, but try

Sub SearchForString()

   Dim UsdRws As Long
   On Error GoTo Err_Execute
   
   With Sheets("LX")
      If .AutoFilterMode Then .AutoFilterMode = False
      UsdRws = Range("A" & Rows.count).End(xlUp).Row
      .Range("A4").AutoFilter 1, "Current"
      Intersect(.Range("A5:A" & usdrw).SpecialCells(xlVisible).EntireRow, .Range("B:C,H:M")).Copy _
      Sheets("In service").Range("A" & Rows.count).End(xlUp).Offset(1)
      .AutoFilterMode = False
      .Range("A3").Select
   End With
   MsgBox "All matching data has been copied."
   Exit Sub
Err_Execute:
    MsgBox "An error occurred."
End Sub

 

[Nine Zero]

The "cheap" and incorrect but doable way would be to just delete the data you dont want after pasting so when everything is done running add this

Range("D:G").Select
Selection.Delete Shift:=xlToLeft

so something like

Sub SearchForString()
    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer


    On Error GoTo Err_Execute
    LSearchRow = 5
    LCopyToRow = 2
    While Len(Range("A" & CStr(LSearchRow)).Value) > 0
        If Range("A" & CStr(LSearchRow)).Value = "Current" Then
            Rows(CStr(LSearchRow) & "B:L" & CStr(LSearchRow)).Select
            Selection.Copy
            Sheets("In Service").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
            LCopyToRow = LCopyToRow + 1
            Sheets("LX").Select
        End If
        LSearchRow = LSearchRow + 1
    Wend
    Application.CutCopyMode = False
    [COLOR=#ff0000]Sheets("In Service").Select
    Range("D:G").Select[/COLOR]
[COLOR=#ff0000]    Selection.Delete Shift:=xlToLeft[/COLOR]

    Range("A3").Select
    MsgBox "All matching data has been copied."
    Exit Sub
Err_Execute:
    MsgBox "An error occurred."
End Sub
[/CODE}

 

[PCL]

Try

Option Explicit
Sub CopyCells()
Const KeyWd  As String = "Current"
Const ColLst  As String = "B,C,H,I,J,K,L,M"
Const WkCol  As String = "A"
Dim WsOrg As Worksheet
Dim WsDest  As Worksheet
Dim I As Integer, LR  As Integer, J  As Integer
Dim K


    Set WsOrg = Sheets("LX")
    Set WsDest = Sheets("In Service")
    With WsOrg
        
        For I = 1 To .Cells(Rows.Count, WkCol).End(3).Row
            If (.Cells(I, WkCol) = KeyWd) Then
                J = 1
                LR = WsDest.Cells(Rows.Count, 1).End(3).Row
                For Each K In Split(ColLst, ",")
                    WsDest.Cells(LR + 1, J) = .Cells(I, K): J = J + 1
                Next K
                LR = LR + 1
            End If
        Next I
    End With
    MsgBox ("Job Done")
End Sub

 

[Timberwolf]

Huge Thank you to everyone, Man you are all so fast!! I went with PCL'S code. but you are all great.

 

[Fluff]

Glad we could help & thanks for the feedback