Macro Edit - Move row data (between columns A:J) to new sheet, based upon cell value.

[BETHROB1993]

I have been using the macro below to move a row of data to a new sheet, if "Done" is selected in column J. However, I only want it to move the data between columns A:J, rather than the entire row. Is someone able to help me edit the below macro, or perhaps offer a new one that will offer the solution?
Completely new to macros :O

Sub Cheezy()
'Updated by Kutools for Excel 2017/8/28
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("J1:J" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Done" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Done" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Try this:

Sub Filter_Me_Please()
'Modified 5/22/18 3:00 AM EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim s As Variant
c = "10" ' Column Number Modify this to your need
s = "Done" 'Search Value Modify to your need
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
With ActiveSheet.Cells(1, 1).Resize(Lastrow, 10)
    .AutoFilter c, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
       .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets(2).Cells(Lastrowa, 1)
     Else
        MsgBox "No values found"
    End If
   .AutoFilter
End With
End Sub

 

[Michael M]

MAybe this

Sub Cheezy()
Dim ws As Worksheet, ws2 As Worksheet, lr As Long, lr2 As Long
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
        If ws.Range("J" & r).Value = "Done" Then
            ws.Range("A" & r & ":J" & r).Copy ws2.Range("A" & lr2 + 1)
            ws.Rows(r).Delete
        End If
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    Next r
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Since I see now you want the row deleted after copying try this:

Sub Filter_Me_Please_New()
'Modified 5/22/18 3:15 AM EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim s As Variant
c = "10" ' Column Number Modify this to your need
s = "Done" 'Search Value Modify to your need
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
With ActiveSheet.Cells(1, 1).Resize(Lastrow, 10)
    .AutoFilter c, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets(2).Cells(Lastrowa, 1)
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
     Else
        MsgBox "No values found"
    End If
   .AutoFilter
End With
End Sub

 

[BETHROB1993]

Thank you - this is so close! This macro still cuts the entire row, although only pastes columns A:J in the new tab. Because I have a second table on the right hand side of my first sheet, I can't have extra columns cut from the first sheet - thanks for the forum tip

MAybe this

Sub Cheezy()
Dim ws As Worksheet, ws2 As Worksheet, lr As Long, lr2 As Long
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 1 Step -1
        If ws.Range("J" & r).Value = "Done" Then
            ws.Range("A" & r & ":J" & r).Copy ws2.Range("A" & lr2 + 1)
            ws.Rows(r).Delete
        End If
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    Next r
Application.ScreenUpdating = True
End Sub

 

[BETHROB1993]

Hi - thank you for your help! Can you help identify where I make changes where I need - for example, names of sheets?

Since I see now you want the row deleted after copying try this:

Sub Filter_Me_Please_New()
'Modified 5/22/18 3:15 AM EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim s As Variant
c = "10" ' Column Number Modify this to your need
s = "Done" 'Search Value Modify to your need
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
With ActiveSheet.Cells(1, 1).Resize(Lastrow, 10)
    .AutoFilter c, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets(2).Cells(Lastrowa, 1)
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
     Else
        MsgBox "No values found"
    End If
   .AutoFilter
End With
End Sub

 

[My Aswer Is This]

If your not sure how to modify sheet names.
Please provide both sheet names.
Copy from sheet name and copy to sheet name
And are you saying on the copy from sheet name you want the cells from column A to J cleared or deleted?

 

[BETHROB1993]

Sorry about that - I need to use the macro across multiple sheets named after properties (so I should be able to adapt it to each sheet), which then moves actions to a completed tab.
For example, one sheet is named "CamillaHouse" (no space), and I need rows of data for this site to clear (between columns A:J only) and move to sheet "Completed Actions", when selected as Done in column J.

If your not sure how to modify sheet names.
Please provide both sheet names.
Copy from sheet name and copy to sheet name
And are you saying on the copy from sheet name you want the cells from column A to J cleared or deleted?

 

[My Aswer Is This]

Try this:
Modify sheet names where marked in red:

Sub Filter_Me_Please_New()
'Modified 5/22/18 8:10 AM EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim s As Variant
Dim CopyFrom As String
Dim CopyTo As String
CopyFrom = "[COLOR=#ff0000]CamillaHouse[/COLOR]" 'Modify as needed
CopyTo = "[COLOR=#ff0000]Completed Actions[/COLOR]"  'Modify as needed
c = "10" ' Column Number Modify this to your need
s = "Done" 'Search Value Modify to your need
Lastrow = Sheets(CopyFrom).Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Sheets(CopyTo).Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheets(CopyFrom).Cells(1, 1).Resize(Lastrow, 10)
    .AutoFilter c, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets(CopyTo).Cells(Lastrowa, 1)
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
     Else
        MsgBox "No values found"
    End If
   .AutoFilter
End With
End Sub

 

[BETHROB1993]

The error reads type mismatch - I have double checked that the names of sheets are completely accurate. I have also changed this: c = "10" ' Column Number Modify this to your need, to read c = "J" ' Column Number Modify this to your need, is this correct? As column J is where a row may read "Done".

Thank you for your help!

Try this:
Modify sheet names where marked in red:

Sub Filter_Me_Please_New()
'Modified 5/22/18 8:10 AM EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim s As Variant
Dim CopyFrom As String
Dim CopyTo As String
CopyFrom = "[COLOR=#ff0000]CamillaHouse[/COLOR]" 'Modify as needed
CopyTo = "[COLOR=#ff0000]Completed Actions[/COLOR]"  'Modify as needed
c = "10" ' Column Number Modify this to your need
s = "Done" 'Search Value Modify to your need
Lastrow = Sheets(CopyFrom).Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Sheets(CopyTo).Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheets(CopyFrom).Cells(1, 1).Resize(Lastrow, 10)
    .AutoFilter c, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets(CopyTo).Cells(Lastrowa, 1)
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
     Else
        MsgBox "No values found"
    End If
   .AutoFilter
End With
End Sub