Copy certain columns versus entire row from one worksheet to another based on text entered in single colum

[rlundbulls23]

Hello,

I've been using the following successfully but now want to modify it to only copy certain columns versus the entire row. I've read various threads but stuck how to include a range or identify specific columns.
Thanks in advance for your help!!

-Bob


Sub CopyRowBasedOnCellValue()

Dim xRg As Range

Dim xCell As Range

Dim A As Long

Dim B As Long

Dim C As Long

A = Worksheets("Master").UsedRange.Rows.Count

B = Worksheets("Sold").UsedRange.Rows.Count

If B = 1 Then

If Application.WorksheetFunction.CountA(Worksheets("Sold").UsedRange) = 0 Then B = 0

End If

Set xRg = Worksheets("Master").Range("D1:D" & A)

On Error Resume Next

Application.ScreenUpdating = False

For C = 1 To xRg.Count

If CStr(xRg(C).Value) = "Done" Then

xRg(C).EntireRow.Copy Destination:=Worksheets("Sold").Range("A" & B + 1)

B = B + 1

End If

Next

Application.ScreenUpdating = True

End Sub

 

[MARK858]

include a range or identify specific columns

What range or specific columns?

 

[mumps]

Change the range (in red) to match the columns you want to copy.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim lRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Master")
    Set desWS = Sheets("Sold")
    Dim v As Variant, i As Long
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        v = .Range("D1:D" & lRow).Value
        For i = LBound(v) To UBound(v)
            If v(i, 1) = "Done" Then
                Intersect(.Rows(i), .Range("A:A,E:E,G:G")).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub