VBA macro to copy rows/columns based on cell value

[Josu]

I have some SQL results which I want to copy based to cell value. I found macro on the internet, but problem is that I don't want to copy/paste entire row.
Only columns from A to E where in column A is word which I am looking for. At the moment macro working fine, but doing entire row which is not really good my needs.
Can you help please to amend macro to copy paste just A-E columns, not entire row

Order Type	Order Date	Hour	Orders	Units
Good	14/12/2022​	00:00 - 01:00	189​	510​
Good	14/12/2022​	01:00 - 02:00	102​	282​
Good	14/12/2022​	02:00 - 03:00	53​	138​
Elite	14/12/2022​	00:00 - 01:00	258​	888​
Elite	14/12/2022​	01:00 - 02:00	109​	390​
Elite	14/12/2022​	02:00 - 03:00	58​	229​
Together	14/12/2022​	00:00 - 01:00	447​	1398​
Together	14/12/2022​	01:00 - 02:00	211​	672​
Together	14/12/2022​	02:00 - 03:00	111​	367​

Sub CopyRow2()
'Declare variables
    Dim sheetNo1 As Worksheet
    Dim sheetNo2 As Worksheet
    Dim sheetNo3 As Worksheet
    Dim sheetNo4 As Worksheet
    Dim FinalRow As Long
    Dim Cell As Range
'Set variables
    Set sheetNo1 = Sheets("SQL")
    Set sheetNo2 = Sheets("Good")
    Set sheetNo3 = Sheets("Elite")
    Set sheetNo4 = Sheets("Together")
'Type a command to select the entire row
    'Selection.EntireRow.Select
    Range("A2:E75").Select
' Define destination sheets to move row
    FinalRow1 = sheetNo1.Range("A" & sheetNo1.Rows.Count).End(xlUp).Row
    FinalRow2 = sheetNo2.Range("A" & sheetNo2.Rows.Count).End(xlUp).Row
    FinalRow3 = sheetNo3.Range("A" & sheetNo3.Rows.Count).End(xlUp).Row
    FinalRow4 = sheetNo4.Range("A" & sheetNo4.Rows.Count).End(xlUp).Row
    With sheetNo1
'Apply loop for column E until last cell with value
    For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        If Cell.Value = "Good" Then
            .Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)
            FinalRow2 = FinalRow2 + 1
'Apply condition to match the "Unsold" value
        ElseIf Cell.Value = "Elite" Then
'Command to Copy and move to a destination Sheet "Unsold2"
            .Rows(Cell.Row).Copy Destination:=sheetNo3.Rows(FinalRow3 + 1)
             FinalRow3 = FinalRow3 + 1
             ElseIf Cell.Value = "Together" Then
'Command to Copy and move to a destination Sheet "Unsold2"
            .Rows(Cell.Row).Copy Destination:=sheetNo4.Rows(FinalRow4 + 1)
             FinalRow4 = FinalRow4 + 1
        End If
     Next Cell
    End With
End Sub

 

[Peter_SSs]

Only columns from A to E ...

Untested by try changing

.Rows(Cell.Row).Copy

to

.Rows(Cell.Row).Resize(, 5).Copy

in each place

 

[Josu]

Untested by try changing

.Rows(Cell.Row).Copy

to

.Rows(Cell.Row).Resize(, 5).Copy

in each place

Thank you, its working!

 

[kevin9999]

You have your solution, but here's some optional code to consider...

Option Explicit
Sub Copy_A_to_E()
    'Declare variables
    Dim sheetNo1 As Worksheet
    Dim sheetNo2 As Worksheet
    Dim sheetNo3 As Worksheet
    Dim sheetNo4 As Worksheet
    'Set variables
    Set sheetNo1 = Sheets("SQL")
    Set sheetNo2 = Sheets("Good")
    Set sheetNo3 = Sheets("Elite")
    Set sheetNo4 = Sheets("Together")

    Dim a, b, i As Long, LRow As Long
    a = Array("Good", "Elite", "Together")
    b = Array(sheetNo2, sheetNo3, sheetNo4)
    
    For i = LBound(a) To UBound(a)
        LRow = b(i).Cells(Rows.Count, 1).End(3).Row + 1
        With sheetNo1.Cells(1).CurrentRegion
            .AutoFilter 1, a(i)
            .Offset(1).Resize(.Rows.Count - 1, 5).Copy _
            b(i).Cells(LRow, 1)
            .AutoFilter
        End With
    Next i

End Sub

 

[Peter_SSs]

Thank you, its working!

You're welcome. Thanks for the follow-up.

 

[Josu]

You have your solution, but here's some optional code to consider...

Option Explicit
Sub Copy_A_to_E()
    'Declare variables
    Dim sheetNo1 As Worksheet
    Dim sheetNo2 As Worksheet
    Dim sheetNo3 As Worksheet
    Dim sheetNo4 As Worksheet
    'Set variables
    Set sheetNo1 = Sheets("SQL")
    Set sheetNo2 = Sheets("Good")
    Set sheetNo3 = Sheets("Elite")
    Set sheetNo4 = Sheets("Together")

    Dim a, b, i As Long, LRow As Long
    a = Array("Good", "Elite", "Together")
    b = Array(sheetNo2, sheetNo3, sheetNo4)
   
    For i = LBound(a) To UBound(a)
        LRow = b(i).Cells(Rows.Count, 1).End(3).Row + 1
        With sheetNo1.Cells(1).CurrentRegion
            .AutoFilter 1, a(i)
            .Offset(1).Resize(.Rows.Count - 1, 5).Copy _
            b(i).Cells(LRow, 1)
            .AutoFilter
        End With
    Next i

End Sub

Wow, this is even shorter and simpler. Thank you, this one also works for my purpose, before I also found something like this, but i need to run 3 times .

 Sub Together() 'Other solution

 
 Dim LR As Long

Dim x1 As Range, y1 As Range
 
 
 With ThisWorkbook.Worksheets("SQL")

    LR = Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For Each x1 In .Range("A2:A" & LR)

        If x1.Text = "Together" Then

            If y1 Is Nothing Then

            Set y1 = .Range("A" & x1.Row).Resize(, 5)

            Else

            Set y1 = Union(y1, .Range("A" & x1.Row).Resize(, 5))

            End If

        End If

        Next x1

        Application.ScreenUpdating = True

    End With
     If Not y1 Is Nothing Then y1.Select
    Selection.Copy Worksheets("Together").Range("A2")
    Sheets("SQL").Activate

End Sub