Cut certain cells in row and paste in Sheet2 if cell in row equals "Yes" and put last

[Vallenato]

Hello!
I have alot of trubbel finding a vba-code that permits me to do the following:

1. I have one sheet with rows and I want to copy certain cells in each row to another sheet (always the same cells to be copied), creating the same row but with only the certain copied cells that I wanted (i.e. the target sheet will show less data for each row than the master sheet). The first cell in each row is one of the cells that will be copied and it will have a unique name, the other cells may include data that can be found in other rows.
2. I only want to copy the row with its certain cells if for each row, a certain cell value in that row says "Yes" AND if the cell value of the unique name to be copied already doesn´t exist in the target sheet.
2. I want the copied row of cells to be put on the first free row in the target sheet. This would mean the last row if every row is already taken in the target sheet or in between rows if there is space.

Is there anyone out there that could help me with a vba-code I would be very happy

 

[Truiz]

Try This:

Sub CCCIRAPISICIREYAPL()    
Dim lRow As Long
Dim lRow2 As Long


lRow = Worksheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    


    
    For i = 2 To lRow Step 1
        If Worksheets("Sheet1").Cells(i, "C") = "Yes" Then
           Worksheets("Sheet1").Range("A" & i & ":B" & i).Cut Worksheets("Sheet2").Range("A" & i)
        End If
    Next


        lRow2 = Worksheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlRows, _
        SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        
   With Worksheets("Sheet2").Sort
      .SortFields.Clear
      .SortFields.Add Key:=Range("A2:A" & lRow2), _
      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Range("A1:B" & lRow)
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
        
    For i = lRow2 To 2 Step -1
        If Worksheets("Sheet2").Cells(i, "A") = Worksheets("Sheet2").Cells(i - 1, "A") Then
           Worksheets("Sheet2").Cells(i, "A").EntireRow.Delete
        End If
    Next
   
End Sub

This assumes the cell value of the unique name to be copied already doesn't exist in the target sheet. is in columnA

Change columns and sheet names as necesary

 

[Vallenato]

Hello Truiz!
Thank you VERY much for responding. Your code almost match what I am looking for. However this is what I want the macro to do (se below). Could you please help me to change the code a little bit so it does what I want it to do? I am VERY pleased for your help!

1. Sheet1 looks like this. I want to copy (not cut) the names marked with “Yes” to Sheet2.
John 22
Pete 78
Rick 44 Yes
Clive 57
Clint 77 Yes
Steve 89

2. When I run the macro sheet2, that was originally blank, will look like this:
Rick 44
Clint 77
---------------------------------------------------------------------------

3. Then later on, I mark different names with “Yes” in Sheet1:
John 22
Pete 78
Rick 44
Clive 57 Yes
Clint 77 Yes
Steve 89

4. I run the macro again and Sheet2 will now look like this (Rick and Clint are still there from the last time I ran the macro, but now Clive gets copied as well and is placed last by the macro). Clint isn´t copied again although it is marked with “Yes” (not ending up as a double in the last row) since it already exists in sheet 2 from the first time I ran the macro.
Rick 44
Clint 77
Clive 57
---------------------------------------------------------------------------

5. Then for some reason I decide to manually erase Clint from sheet 2 leaving a blank row in between Rick and Clive:
Rick 44

Clive 57
---------------------------------------------------------------------------

6. When I run the macro again and for example mark “Yes” on John, John gets copied to sheet 2.
John 22 Yes
Pete 78
Rick 44
Clive 57
Clint 77
Steve 89

7. … and John is put in between Rick and Clive in sheet2 where it before was a blank row since the macro will copy data and put it in empty rows in between if they exist or at the end if no empty rows exist:
Rick 44
John 22
Clive 57

---------------------------------------------------------------------------
8. And so on. (Extra: If I made a mistake and put “Yes” on a row in sheet 1 that contained no data in the first column the macro will ignore the copy of that cell to sheet 2)

 

[Vallenato]

(in the example above the names are in column A, the numbers are in column B and "Yes" is in column C)

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim name As Range
    Dim foundName As Range
    Dim x As Long
    Dim bottomA As Long
    For Each name In Sheets("Sheet1").Range("A2:A" & LastRow)
        Set foundName = Sheets("Sheet2").Range("A:A").Find(name, LookIn:=xlValues, lookat:=xlWhole)
        If foundName Is Nothing And name.Offset(0, 2) = "Yes" Then
            bottomA = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
            x = Sheets("Sheet2").Range("A2:A" & bottomA).Find("").Row
            Sheets("Sheet1").Range("A" & name.Row & ":B" & name.Row).Copy Sheets("Sheet2").Cells(x, 1)
        End If
    Next name
    Application.ScreenUpdating = True
End Sub

 

[Vallenato]

Mumps!
What a great code. Thanks alot!!!! You solved the big problem I had. You are the hero of the day! Ok, one last question: I have in sheet1 alot of conditional formatting that I don´t want to be copied over to sheet2 when I run this macro (I only want the value inside the cell to be copied). Is there some way to include something in the code that stops the conditional formatting to be copied?

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim name As Range
    Dim foundName As Range
    Dim x As Long
    Dim bottomA As Long
    For Each name In Sheets("Sheet1").Range("A2:A" & LastRow)
        Set foundName = Sheets("Sheet2").Range("A:A").Find(name, LookIn:=xlValues, lookat:=xlWhole)
        If foundName Is Nothing And name.Offset(0, 2) = "Yes" Then
            bottomA = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
            x = Sheets("Sheet2").Range("A2:A" & bottomA).Find("").Row
            Sheets("Sheet1").Range("A" & name.Row & ":B" & name.Row).Copy
            Sheets("Sheet2").Cells(x, 1).PasteSpecial xlPasteValues
        End If
    Next name
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Vallenato]

YES!!!! Now it works! Perfect! Thank you very much for your help!!!!!!!!!!!!!!!!!!!!!!

 

[mumps]

You are very welcome.