Copy rows from one sheet to another that meet a given criteria?

[emptiness_void]

Hello guys! Hope u are good!

Could someone please help me with this code I'm trying to edit an reach my goal?

Goal: copy rows from a Sheet1 to a Sheet2, that meet a criteria, with a Date and time record!

for example, all rows that have yellow as text in the colum G of sheet one, after I click in a button, they should be copied for the Sheet2! And adding the date and time of that action in the historic in Sheet 2!

Here goes an example of what I'm trying to achive:
Sheet1

Sheet2

Here follows the code I'm using atm:

Sub Sample()
    Dim wb1 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim copyFrom As Range
    
    Dim myArr As Variant
    
    Dim lRow As Long
    Dim strSearch As String

    Dim i As Long, j As Long
    Dim upper As Long, down As Long


    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets("Sheet1")

    strSearch = "yellow"

    With ws1

        .AutoFilterMode = False

        lRow = .Range("G" & .Rows.Count).End(xlUp).Row

        With .Range("G1:G" & lRow)
            .AutoFilter Field:=7, Criteria1:="=*" & strSearch & "*"
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With


        .AutoFilterMode = False
    End With

    Set ws2 = wb1.Worksheets("Sheet2")

    With ws2
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lRow = 1
        End If

        myArr = copyFrom.Value ' I can't find a way to copy the values in the Array
        upper = UBound(myArr)
        MsgBox (upper)


        ReDim Preserve myArr(0 To upper, 0 To down)

        For i = 1 To UBound(myArr)
            For j = UBound(X, 2) To 2 Step -1
                myArr(i, j) = myArr(i, j - 1)
            Next
            myArr(i, 1) = Format(Now, "mm/dd/yyyy HH:mm:ss")
        Next



        myArr.Copy .Rows(lRow)
    End With


End Sub

I thought 2 ways to achieve this:

1. Pass the values in the range to an Array and the resize the array to add the date&time to the first column; OR
2. Copy the range after the first column in Sheet2, and then fill the blanks for the rows copied, with the date & time.

I was tryin the fist option with no success, is there a way around this?

Thank you in advance

 

[vcoolio]

Hello EV,

This may help:-

Sub Test()

Application.ScreenUpdating = False

        Sheet1.Columns(1).Insert
        
        With Sheet1.[A1].CurrentRegion
                .AutoFilter 8, "Yellow"
                         .Offset(1).Resize(.Rows.Count - 1, 1) = Format(Now)
                         .Offset(1).Resize(.Rows.Count - 1).Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
                         .Offset(1).EntireRow.Delete
                .AutoFilter
                .Columns(1).Delete
        End With
        
        Sheet2.Columns.AutoFit
        
Application.ScreenUpdating = True

End Sub

The code copy/pastes the rows with the criteria "Yellow" to Sheet2 and adds a Date/Time stamp in Column A of sheet2 for each transfer of data. The Date/Time stamp stays fixed on the time of execution. The relevant rows of data are then deleted from Sheet1.

I hope that this helps.

Cheerio,
vcoolio.

 

[emptiness_void]

I don't know whats happening, I tried your code in the sample example and your code worked, but I did the same thing for the working file and it gives me this error:

Could you possibly know whats happening? I just changed the Sheet numbers to match the ones in the file!

 

[emptiness_void]

I think I know whats the problem, in our working file, the dataset is defined as a Table and not a free range! That's why it's giving me this error!

What can I do to turn this around?

 

[vcoolio]

Hello EV,

I don't know whats happening, I tried your code in the sample example and your code worked, but I did the same thing for the working file and it gives me this error:

That's why, when a sample is supplied, we need it to be an exact replica of your actual workbook. Please bear this in mind should you require any future assistance.
Anyway, try it as follows:-

Sub Test()

Dim lr As Long

Application.ScreenUpdating = False

Sheet1.ListObjects("Table1").Unlist

        Sheet1.Columns(1).Insert
        
        With Sheet1.[A1].CurrentRegion
                .AutoFilter 8, "Yellow"
                         .Offset(1).Resize(.Rows.Count - 1, 1) = Format(Now)
                         .Offset(1).Resize(.Rows.Count - 1).Copy
                         Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
                         .Offset(1).EntireRow.Delete
                .AutoFilter
                .Columns(1).Delete
        End With
        
        Sheet2.Columns.AutoFit
        
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Sheet1.ListObjects.Add(xlSrcRange, Range("A1:M" & lr), , xlYes).Name = "Table1"

Application.ScreenUpdating = True

End Sub

I'm using the sheet codes not the sheet names in the above VBA sub so alter the sheet codes to suit yourself. I've referred to the table as "Table1" so you may have to change this as well to suit.
I'm also assuming that the transferred data is not going to a table in the destination sheet.

I hope that this helps.

Cheerio,
vcoolio.