copy cells to sheet if statement is true

[cclinton]

New to VBA and Macros but am in need of one to perform a task.

My goal: if a particular cell in one sheet has an x, then two cells from that same row are copied to a new space row in another sheet.

More details:
If space G3 contains an x I want cells E3 and F3 copied to a second sheet at cell A25 and B25. I want this code to check every row in column G from row 3 to whenever I stop adding rows. I want every row that does have an x to place those copied cells below space A25-B25, or add above and move the first down, whatever is easier.

I did find code that is supposed to copy a whole row:
Sub Search_and_Move()
Dim sTemp As String
sTemp = Sheet3.Range("G3").Text
If InStr(1, sTemp, "x", vbTextCompare) Then Range("A3").EntireRow.Copy _
Destination:=Sheet2.Range("A25")
End Sub

I couldn't even get this to work. Not sure if the Sheet2 and Sheet3 needed to be named by the names I added to the tabs or if something else was the issue. Then I need to figure out how to just copy specific cells and paste into specific cells...

I am trying to use this as a learning experience. Thanks for any help you can provide.

 

[AlphaFrog]

Give this a try. Use your actual sheet names in red to define the source and destination worksheets.

Sub Search_and_Move()

    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim FoundX As Range, Firstfound As String, Lastrow As Long
    
    Set wsSource = Worksheets("[COLOR="Red"]Sheet1[/COLOR]")     ' Source worksheet
    Set wsDest = Worksheets("[COLOR="Red"]Sheet3[/COLOR]")       ' Destination worksheet
    
    ' Find the first cell in column G with an "X" in it
    Set FoundX = wsSource.Range("G:G").Find("x", After:=wsSource.Range("G" & Rows.Count), _
                                 LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
    
    If FoundX Is Nothing Then
    
        MsgBox "No X's found.", vbCritical, "Done!"
        Exit Sub
        
    Else    'Copy values
        
        
        Firstfound = FoundX.Address                                     ' Remember the first found "X" cell address. Prevents an endless loop.
        
        Lastrow = wsDest.Range("A" & Rows.Count).End(xlUp).Row + 1      ' Next empty row on Destination sheet
        If Lastrow < 25 Then Lastrow = 25
        
        Do
            
            'Copy E:F values from source worksheet to next empty row on the destination worksheet in columns A:B
            wsDest.Range("A" & Lastrow).Resize(1, 2).Value = FoundX.Offset(0, -2).Resize(1, 2).Value
            
            Lastrow = Lastrow + 1                                       ' Row counter
            
            Set FoundX = wsSource.Range("G:G").FindNext(FoundX)         ' Find next "X" in column G
            
        Loop Until FoundX.Address = Firstfound                          ' Do until the first "X" address is found again
    
    End If
    
    MsgBox "All Xed values copied.", vbInformation, "Done!"
    
End Sub

 

[cclinton]

Thanks for the code. A couple observations/questions:

I noticed this code always looks for the first blank row in column A on the 2nd sheet. Even though it says begin at row 24, it always looks looks for the first blank cell in that column and starts there.

I tried copying the code and rewriting it to allow for the same function on other columns and it appears the Search_and_Move code doesn't like to be run more than once on a page.

Now that I know the code works, I'd like to draw it out to do the same thing for three columns in the first sheet.

If x in column G, then copy cells to A24 in 2nd sheet.
If x in column H, then copy cells to C24 in 2nd sheet.
If X in column I, then copy cells to E24 in 2nd sheet.

first try: copy and paste code below and change the parameters. Result: didn't like performing the same code multiple times.
2nd try: copying pieces of the code and loading them right below the first rows of code. For instance, if it said to check row G and copy something I added a row below for checking row H and copying something. Result: glitches and nothing appeared.

I am thus making an assumption that I need to tell it to look in all three columns and if the X is in G, do this, if X is in H do this and if x is in I do this in one sentence of code.

 

[AlphaFrog]

I noticed this code always looks for the first blank row in column A on the 2nd sheet. Even though it says begin at row 24, it always looks looks for the first blank cell in that column and starts there.

It looks for the 1st blank row but if the 1st blank row is above row 24 then it starts ant row 24. I made an assumption that's what you wanted.

If x in column G, then copy cells to A24 in 2nd sheet.
If x in column H, then copy cells to C24 in 2nd sheet.
If X in column I, then copy cells to E24 in 2nd sheet.

Sub Search_and_Move()

    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim FoundX As Range, Firstfound As String, Lastrow As Long
    
    Set wsSource = Worksheets("Sheet1")     ' Source worksheet
    Set wsDest = Worksheets("Sheet3")       ' Destination worksheet
    
    Lastrow = wsDest.Cells.Find("*", After:=wsDest.Range("A1"), _
         SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1   ' Next empty row on Destination sheet
    If Lastrow < 25 Then Lastrow = 25
    
    ' Find the first cell in column G with an "X" in it
    Set FoundX = wsSource.Range("G:I").Find("x", After:=wsSource.Range("I" & Rows.Count), _
                                 LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
    
    If FoundX Is Nothing Then
    
        MsgBox "No X's found.", vbCritical, "Done!"
        
    Else    'Copy values
        
        Firstfound = FoundX.Address    ' Remember the first found "X" cell address. Prevents an endless loop.
        
        Do
            
            ' Copy E:F values from source worksheet to next empty row on the destination worksheet
            ' If X in source column G then copy to destination columns A:B
            ' If X in source column H then copy to destination columns C:D
            ' If X in source column I then copy to destination columns E:F
            wsDest.Range("A" & Lastrow).Offset(0, (FoundX.Column - 7) * 2).Resize(1, 2).Value = _
                                                wsSource.Range("E" & FoundX.Row).Resize(1, 2).Value
            
            Lastrow = Lastrow + 1                                       ' Row counter
            
            Set FoundX = wsSource.Range("G:I").FindNext(FoundX)         ' Find next "X" in column G
            
        Loop Until FoundX.Address = Firstfound                          ' Do until the first "X" address is found again
        
        MsgBox "All Xed values copied.", vbInformation, "Done!"
    
    End If
    
End Sub

 

[cclinton]

Awesome, works like a charm.

 

[jaamainen]

Hi!

It works great! Can someone help me and make a samething with entire row?

There are 2 sheets... Sheet1 and Sheet2

All of the data are in sheet1 and i make things to the new sheet2

If there is a "x" in column O it would copy entire row to the sheet2

Thanks!