Need help with Macro to copy a range

[SpeedyKevin]

Hey All!

I'm in need of help on this macro. What I have it doing is searching the sheet for certain things and copying them over to another sheet. However it copies the entire row (which isn't needed) and I was hoping I could just set it to copy the first 3 columns of that row.


The macro is below
The area I think that needs changing is in Red.

Thanks!
Kevin



'Start search in row 1 in Sheet1
LSearchRow = 1

'Start copying data to row 1 in Red (row counter variable)
LCopyToRow = 1

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

'If value in column C = "RED", copy entire row to CopySheet
If Range("C" & CStr(LSearchRow)).Value = "RED" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into RED in next row
Sheets("RED").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

 

[Fluff]

How about

Sub SpeedyKevin()
   With Sheets("Sheet1")
      .Range("A1:C1").AutoFilter 1, "RED"
      .AutoFilter.Range.Copy Sheets("RED").Range("A2")
      .AutoFilterMode = False
   End With
End Sub

 

[My Aswer Is This]

Try this:

Sub Copy_Red()
'Modified 4/29/2019 2:15:53 PM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowr As Long
Sheets("Sheet1").Activate
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrowr = Sheets("Red").Cells(Rows.Count, "C").End(xlUp).Row + 1
For i = 1 To Lastrow
    If Cells(i, "C").Value = "Red" Then
        Cells(i, 1).Resize(, 3).Copy Sheets("Red").Cells(Lastrowr, 1)
        Lastrowr = Lastrowr + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Or if you want to see how a filter works try this:
A Filter is faster if your working with a large number of rows.

Sub Filter_Me_Red()
'Modified  4/29/2019  2:36:29 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim lastrowr As Long
lastrowr = Sheets("Red").Cells(Rows.Count, "A").End(xlUp).Row + 1
Dim c As Long
Dim s As Variant
c = 3 ' Column Number Modify this to your need
s = "Red" 'Search Value Modify to your need
lastrow = Cells(Rows.Count, c).End(xlUp).Row
With ActiveSheet.Cells(1, c).Resize(lastrow)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Offset(, -2).Resize(.Rows.Count - 1, 3).SpecialCells(xlCellTypeVisible).Copy Sheets("Red").Cells(lastrowr, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub